diff options
| author | Sébastien Delafond <sdelafond@gmail.com> | 2014-07-13 13:35:01 +0200 |
|---|---|---|
| committer | Sébastien Delafond <sdelafond@gmail.com> | 2014-07-13 13:35:01 +0200 |
| commit | 7697fa4daf3ec84f85711a84035d8f0224afd4e3 (patch) | |
| tree | 24d0f1d2a9751ca8c063409fd2ab71478b296efb /contrib/lisp | |
Imported Upstream version 7.9.2
Diffstat (limited to 'contrib/lisp')
53 files changed, 41227 insertions, 0 deletions
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, +\"©\" *always* refers to the copyright symbol, regardless of charset +specified by the META tag or the charset sent by the HTTP server. In +other words, \"©\" is exactly equivalent to \"©\". + +By default, entity conversion is turned on for Mule-enabled Emacsen and +turned off otherwise. This is because Mule knows the charset of +non-ASCII characters in the buffer. A non-Mule Emacs cannot tell +whether a character with code 0xA9 represents Latin 1 copyright symbol, +Latin 2 \"S with caron\", or something else altogether. Setting this to +t without Mule means asserting that 128-255 characters always mean Latin +1. + +For most people htmlize will work fine with this option left at the +default setting; don't change it unless you know what you're doing." + :type 'sexp + :group 'htmlize) + +(defcustom htmlize-ignore-face-size 'absolute + "*Whether face size should be ignored when generating HTML. +If this is nil, face sizes are used. If set to t, sizes are ignored +If set to `absolute', only absolute size specifications are ignored. +Please note that font sizes only work with CSS-based output types." + :type '(choice (const :tag "Don't ignore" nil) + (const :tag "Ignore all" t) + (const :tag "Ignore absolute" absolute)) + :group 'htmlize) + +(defcustom htmlize-css-name-prefix "" + "*The prefix used for CSS names. +The CSS names that htmlize generates from face names are often too +generic for CSS files; for example, `font-lock-type-face' is transformed +to `type'. Use this variable to add a prefix to the generated names. +The string \"htmlize-\" is an example of a reasonable prefix." + :type 'string + :group 'htmlize) + +(defcustom htmlize-use-rgb-txt t + "*Whether `rgb.txt' should be used to convert color names to RGB. + +This conversion means determining, for instance, that the color +\"IndianRed\" corresponds to the (205, 92, 92) RGB triple. `rgb.txt' +is the X color database that maps hundreds of color names to such RGB +triples. When this variable is non-nil, `htmlize' uses `rgb.txt' to +look up color names. + +If this variable is nil, htmlize queries Emacs for RGB components of +colors using `color-instance-rgb-components' and `x-color-values'. +This can yield incorrect results on non-true-color displays. + +If the `rgb.txt' file is not found (which will be the case if you're +running Emacs on non-X11 systems), this option is ignored." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-html-major-mode nil + "The mode the newly created HTML buffer will be put in. +Set this to nil if you prefer the default (fundamental) mode." + :type '(radio (const :tag "No mode (fundamental)" nil) + (function-item html-mode) + (function :tag "User-defined major mode")) + :group 'htmlize) + +(defvar htmlize-before-hook nil + "Hook run before htmlizing a buffer. +The hook functions are run in the source buffer (not the resulting HTML +buffer).") + +(defvar htmlize-after-hook nil + "Hook run after htmlizing a buffer. +Unlike `htmlize-before-hook', these functions are run in the generated +HTML buffer. You may use them to modify the outlook of the final HTML +output.") + +(defvar htmlize-file-hook nil + "Hook run by `htmlize-file' after htmlizing a file, but before saving it.") + +(defvar htmlize-buffer-places) + +;;; Some cross-Emacs compatibility. + +;; I try to conditionalize on features rather than Emacs version, but +;; in some cases checking against the version *is* necessary. +(defconst htmlize-running-xemacs (string-match "XEmacs" emacs-version)) + +(eval-and-compile + ;; save-current-buffer, with-current-buffer, and with-temp-buffer + ;; are not available in 19.34 and in older XEmacsen. Strictly + ;; speaking, we should stick to our own namespace and define and use + ;; htmlize-save-current-buffer, etc. But non-standard special forms + ;; are a pain because they're not properly fontified or indented and + ;; because they look weird and ugly. So I'll just go ahead and + ;; define the real ones if they're not available. If someone + ;; convinces me that this breaks something, I'll switch to the + ;; "htmlize-" namespace. + (unless (fboundp 'save-current-buffer) + (defmacro save-current-buffer (&rest forms) + `(let ((__scb_current (current-buffer))) + (unwind-protect + (progn ,@forms) + (set-buffer __scb_current))))) + (unless (fboundp 'with-current-buffer) + (defmacro with-current-buffer (buffer &rest forms) + `(save-current-buffer (set-buffer ,buffer) ,@forms))) + (unless (fboundp 'with-temp-buffer) + (defmacro with-temp-buffer (&rest forms) + (let ((temp-buffer (gensym "tb-"))) + `(let ((,temp-buffer + (get-buffer-create (generate-new-buffer-name " *temp*")))) + (unwind-protect + (with-current-buffer ,temp-buffer + ,@forms) + (and (buffer-live-p ,temp-buffer) + (kill-buffer ,temp-buffer)))))))) + +;; We need a function that efficiently finds the next change of a +;; property (usually `face'), preferably regardless of whether the +;; change occurred because of a text property or an extent/overlay. +;; As it turns out, it is not easy to do that compatibly. +;; +;; Under XEmacs, `next-single-property-change' does that. Under GNU +;; Emacs beginning with version 21, `next-single-char-property-change' +;; is available and does the same. GNU Emacs 20 had +;; `next-char-property-change', which we can use. GNU Emacs 19 didn't +;; provide any means for simultaneously examining overlays and text +;; properties, so when using Emacs 19.34, we punt and fall back to +;; `next-single-property-change', thus ignoring overlays altogether. + +(cond + (htmlize-running-xemacs + ;; XEmacs: good. + (defun htmlize-next-change (pos prop &optional limit) + (next-single-property-change pos prop nil (or limit (point-max))))) + ((fboundp 'next-single-char-property-change) + ;; GNU Emacs 21: good. + (defun htmlize-next-change (pos prop &optional limit) + (next-single-char-property-change pos prop nil limit))) + ((fboundp 'next-char-property-change) + ;; GNU Emacs 20: bad, but fixable. + (defun htmlize-next-change (pos prop &optional limit) + (let ((done nil) + (current-value (get-char-property pos prop)) + newpos next-value) + ;; Loop over positions returned by next-char-property-change + ;; until the value of PROP changes or we've hit EOB. + (while (not done) + (setq newpos (next-char-property-change pos limit) + next-value (get-char-property newpos prop)) + (cond ((eq newpos pos) + ;; Possibly at EOB? Whatever, just don't infloop. + (setq done t)) + ((eq next-value current-value) + ;; PROP hasn't changed -- keep looping. + ) + (t + (setq done t))) + (setq pos newpos)) + pos))) + (t + ;; GNU Emacs 19.34: hopeless, cannot properly support overlays. + (defun htmlize-next-change (pos prop &optional limit) + (unless limit + (setq limit (point-max))) + (let ((res (next-single-property-change pos prop))) + (if (or (null res) + (> res limit)) + limit + res))))) + +;;; Transformation of buffer text: HTML escapes, untabification, etc. + +(defvar htmlize-basic-character-table + ;; Map characters in the 0-127 range to either one-character strings + ;; or to numeric entities. + (let ((table (make-vector 128 ?\0))) + ;; Map characters in the 32-126 range to themselves, others to + ;; &#CODE entities; + (dotimes (i 128) + (setf (aref table i) (if (and (>= i 32) (<= i 126)) + (char-to-string i) + (format "&#%d;" i)))) + ;; Set exceptions manually. + (setf + ;; Don't escape newline, carriage return, and TAB. + (aref table ?\n) "\n" + (aref table ?\r) "\r" + (aref table ?\t) "\t" + ;; Escape &, <, and >. + (aref table ?&) "&" + (aref table ?<) "<" + (aref table ?>) ">" + ;; Not escaping '"' buys us a measurable speedup. It's only + ;; necessary to quote it for strings used in attribute values, + ;; which htmlize doesn't do. + ;(aref table ?\") """ + ) + table)) + +;; A cache of HTML representation of non-ASCII characters. Depending +;; on availability of `encode-char' and the setting of +;; `htmlize-convert-nonascii-to-entities', this maps non-ASCII +;; characters to either "&#<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 @. +`htmlize-make-hyperlinks' uses this to spam-protect mailto links +without modifying their meaning." + ;; Suggested by Ville Skytta. + (while (string-match "@" string) + (setq string (replace-match "@" nil t string))) + string) + +(defun htmlize-make-hyperlinks () + "Make hyperlinks in HTML." + ;; Function originally submitted by Ville Skytta. Rewritten by + ;; Hrvoje Niksic, then modified by Ville Skytta and Hrvoje Niksic. + (goto-char (point-min)) + (while (re-search-forward + "<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>" + nil t) + (let ((address (match-string 3)) + (link-text (match-string 1))) + (delete-region (match-beginning 0) (match-end 0)) + (insert "<<a href=\"mailto:" + (htmlize-despam-address address) + "\">" + (htmlize-despam-address link-text) + "</a>>"))) + (goto-char (point-min)) + (while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;]+\\)\\)>" + nil t) + (let ((url (match-string 3)) + (link-text (match-string 1))) + (delete-region (match-beginning 0) (match-end 0)) + (insert "<<a href=\"" url "\">" link-text "</a>>")))) + +;; 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:" 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 + '(("\\\\-" . "­") + ("---\\([^-]\\)" . "—\\1") + ("--\\([^-]\\)" . "–\\1") + ("\\.\\.\\." . "…")) + "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 + '(("&" . "&") + ("<" . "<") + (">" . ">")) + "Alist of characters to be converted by `org-e-html-protect'." + :group 'org-export-e-html + :type '(repeat (cons (string :tag "Character") + (string :tag "HTML equivalent")))) + +(defcustom org-e-html-quotes + '(("fr" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "« ") + ("\\(\\S-\\)\"" . " »") + ("\\(\\s-\\|(\\|^\\)'" . "’")) + ("en" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "“") + ("\\(\\S-\\)\"" . "”") + ("\\(\\s-\\|(\\|^\\)'" . "‘"))) + "Alist for quotes to use when converting english double-quotes. + +The CAR of each item in this alist is the language code. +The CDR of each item in this alist is a list of three CONS: +- the first CONS defines the opening quote; +- the second CONS defines the closing quote; +- the last CONS defines single quotes. + +For each item in a CONS, the first string is a regexp +for allowed characters before/after the quote, the second +string defines the replacement string for this quote." + :group 'org-export-e-html + :type '(list + (cons :tag "Opening quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")) + (cons :tag "Closing quote" + (string :tag "Regexp for char after ") + (string :tag "Replacement quote ")) + (cons :tag "Single quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")))) + + +;;;; Src Block + +(defcustom org-export-e-htmlize-output-type 'inline-css + "Output type to be used by htmlize when formatting code snippets. +Choices are `css', to export the CSS selectors only, or `inline-css', to +export the CSS attribute values inline in the HTML. We use as default +`inline-css', in order to make the resulting HTML self-containing. + +However, this will fail when using Emacs in batch mode for export, because +then no rich font definitions are in place. It will also not be good if +people with different Emacs setup contribute HTML files to a website, +because the fonts will represent the individual setups. In these cases, +it is much better to let Org/Htmlize assign classes only, and to use +a style file to define the look of these classes. +To get a start for your css file, start Emacs session and make sure that +all the faces you are interested in are defined, for example by loading files +in all modes you want. Then, use the command +\\[org-export-e-htmlize-generate-css] to extract class definitions." + :group 'org-export-e-htmlize + :type '(choice (const css) (const inline-css))) + +(defcustom org-export-e-htmlize-css-font-prefix "org-" + "The prefix for CSS class names for htmlize font specifications." + :group 'org-export-e-htmlize + :type 'string) + +(defcustom org-export-e-htmlized-org-css-url nil + "URL pointing to a CSS file defining text colors for htmlized Emacs buffers. +Normally when creating an htmlized version of an Org buffer, htmlize will +create CSS to define the font colors. However, this does not work when +converting in batch mode, and it also can look bad if different people +with different fontification setup work on the same website. +When this variable is non-nil, creating an htmlized version of an Org buffer +using `org-export-as-org' will remove the internal CSS section and replace it +with a link to this URL." + :group 'org-export-e-htmlize + :type '(choice + (const :tag "Keep internal css" nil) + (string :tag "URL or local href"))) + + +;;;; Table + +(defcustom org-e-html-table-tag + "<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 " ") (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 " ")))) + +;;;; 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 " ") 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>[ ]</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 " ")) + (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 "–" (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 " ")))))) + (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"))) + + +;;;; Text markup + +(defcustom org-e-latex-text-markup-alist '((bold . "\\textbf{%s}") + (code . verb) + (italic . "\\emph{%s}") + (strike-through . "\\st{%s}") + (underline . "\\underline{%s}") + (verbatim . protectedtexttt)) + "Alist of LaTeX expressions to convert text markup. + +The key must be a symbol among `bold', `code', `italic', +`strike-through', `underline' and `verbatim'. The value is +a formatting string to wrap fontified text with. + +Value can also be set to the following symbols: `verb' and +`protectedtexttt'. For the former, Org will use \"\\verb\" to +create a format string and select a delimiter character that +isn't in the string. For the latter, Org will use \"\\texttt\" +to typeset and try to protect special characters. + +If no association can be found for a given markup, text will be +returned as-is." + :group 'org-export-e-latex + :type 'alist + :options '(bold code italic strike-through underline verbatim)) + + +;;;; Drawers + +(defcustom org-e-latex-format-drawer-function nil + "Function called to format a drawer in LaTeX code. + +The function must accept two parameters: + NAME the drawer name, like \"LOGBOOK\" + CONTENTS the contents of the drawer. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-latex-format-drawer-default \(name contents\) + \"Format a drawer element for LaTeX export.\" + contents\)" + :group 'org-export-e-latex + :type 'function) + + +;;;; Inlinetasks + +(defcustom org-e-latex-format-inlinetask-function nil + "Function called to format an inlinetask in LaTeX code. + +The function must accept six parameters: + TODO the todo keyword, as a string + TODO-TYPE the todo type, a symbol among `todo', `done' and nil. + PRIORITY the inlinetask priority, as a string + NAME the inlinetask name, as a string. + TAGS the inlinetask tags, as a list of strings. + CONTENTS the contents of the inlinetask, as a string. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-latex-format-inlinetask \(todo type priority name tags contents\) +\"Format an inline task element for LaTeX export.\" + \(let ((full-title + \(concat + \(when todo + \(format \"\\\\textbf{\\\\textsf{\\\\textsc{%s}}} \" todo)) + \(when priority (format \"\\\\framebox{\\\\#%c} \" priority)) + title + \(when tags + \(format \"\\\\hfill{}\\\\textsc{:%s:}\" + \(mapconcat 'identity tags \":\"))))) + \(format (concat \"\\\\begin{center}\\n\" + \"\\\\fbox{\\n\" + \"\\\\begin{minipage}[c]{.6\\\\textwidth}\\n\" + \"%s\\n\\n\" + \"\\\\rule[.8em]{\\\\textwidth}{2pt}\\n\\n\" + \"%s\" + \"\\\\end{minipage}}\" + \"\\\\end{center}\") + full-title contents))" + :group 'org-export-e-latex + :type 'function) + + +;; Src blocks + +(defcustom org-e-latex-listings nil + "Non-nil means export source code using the listings package. +This package will fontify source code, possibly even with color. +If you want to use this, you also need to make LaTeX use the +listings package, and if you want to have color, the color +package. Just add these to `org-export-latex-packages-alist', +for example using customize, or with something like: + + \(require 'org-e-latex) + \(add-to-list 'org-export-latex-packages-alist '\(\"\" \"listings\")) + \(add-to-list 'org-export-latex-packages-alist '\(\"\" \"color\")) + +Alternatively, + + \(setq org-e-latex-listings 'minted) + +causes source code to be exported using the minted package as +opposed to listings. If you want to use minted, you need to add +the minted package to `org-export-latex-packages-alist', for +example using customize, or with + + \(require 'org-e-latex) + \(add-to-list 'org-export-latex-packages-alist '\(\"\" \"minted\")) + +In addition, it is necessary to install pygments +\(http://pygments.org), and to configure the variable +`org-e-latex-pdf-process' so that the -shell-escape option is +passed to pdflatex." + :group 'org-export-e-latex + :type '(choice + (const :tag "Use listings" t) + (const :tag "Use minted" 'minted) + (const :tag "Export verbatim" nil))) + +(defcustom org-e-latex-listings-langs + '((emacs-lisp "Lisp") (lisp "Lisp") (clojure "Lisp") + (c "C") (cc "C++") + (fortran "fortran") + (perl "Perl") (cperl "Perl") (python "Python") (ruby "Ruby") + (html "HTML") (xml "XML") + (tex "TeX") (latex "TeX") + (shell-script "bash") + (gnuplot "Gnuplot") + (ocaml "Caml") (caml "Caml") + (sql "SQL") (sqlite "sql")) + "Alist mapping languages to their listing language counterpart. +The key is a symbol, the major mode symbol without the \"-mode\". +The value is the string that should be inserted as the language +parameter for the listings package. If the mode name and the +listings name are the same, the language does not need an entry +in this list - but it does not hurt if it is present." + :group 'org-export-e-latex + :type '(repeat + (list + (symbol :tag "Major mode ") + (string :tag "Listings language")))) + +(defcustom org-e-latex-listings-options nil + "Association list of options for the latex listings package. + +These options are supplied as a comma-separated list to the +\\lstset command. Each element of the association list should be +a list containing two strings: the name of the option, and the +value. For example, + + (setq org-e-latex-listings-options + '((\"basicstyle\" \"\\small\") + (\"keywordstyle\" \"\\color{black}\\bfseries\\underbar\"))) + +will typeset the code in a small size font with underlined, bold +black keywords. + +Note that the same options will be applied to blocks of all +languages." + :group 'org-export-e-latex + :type '(repeat + (list + (string :tag "Listings option name ") + (string :tag "Listings option value")))) + +(defcustom org-e-latex-minted-langs + '((emacs-lisp "common-lisp") + (cc "c++") + (cperl "perl") + (shell-script "bash") + (caml "ocaml")) + "Alist mapping languages to their minted language counterpart. +The key is a symbol, the major mode symbol without the \"-mode\". +The value is the string that should be inserted as the language +parameter for the minted package. If the mode name and the +listings name are the same, the language does not need an entry +in this list - but it does not hurt if it is present. + +Note that minted uses all lower case for language identifiers, +and that the full list of language identifiers can be obtained +with: + + pygmentize -L lexers" + :group 'org-export-e-latex + :type '(repeat + (list + (symbol :tag "Major mode ") + (string :tag "Minted language")))) + +(defcustom org-e-latex-minted-options nil + "Association list of options for the latex minted package. + +These options are supplied within square brackets in +\\begin{minted} environments. Each element of the alist should +be a list containing two strings: the name of the option, and the +value. For example, + + \(setq org-e-latex-minted-options + '\((\"bgcolor\" \"bg\") \(\"frame\" \"lines\"))) + +will result in src blocks being exported with + +\\begin{minted}[bgcolor=bg,frame=lines]{<LANG>} + +as the start of the minted environment. Note that the same +options will be applied to blocks of all languages." + :group 'org-export-e-latex + :type '(repeat + (list + (string :tag "Minted option name ") + (string :tag "Minted option value")))) + +(defvar org-e-latex-custom-lang-environments nil + "Alist mapping languages to language-specific LaTeX environments. + +It is used during export of src blocks by the listings and minted +latex packages. For example, + + \(setq org-e-latex-custom-lang-environments + '\(\(python \"pythoncode\"\)\)\) + +would have the effect that if org encounters begin_src python +during latex export it will output + + \\begin{pythoncode} + <src block body> + \\end{pythoncode}") + + +;;;; Plain text + +(defcustom org-e-latex-quotes + '(("fr" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "«~") + ("\\(\\S-\\)\"" . "~»") + ("\\(\\s-\\|(\\|^\\)'" . "'")) + ("en" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "``") + ("\\(\\S-\\)\"" . "''") + ("\\(\\s-\\|(\\|^\\)'" . "`"))) + "Alist for quotes to use when converting english double-quotes. + +The CAR of each item in this alist is the language code. +The CDR of each item in this alist is a list of three CONS: +- the first CONS defines the opening quote; +- the second CONS defines the closing quote; +- the last CONS defines single quotes. + +For each item in a CONS, the first string is a regexp +for allowed characters before/after the quote, the second +string defines the replacement string for this quote." + :group 'org-export-e-latex + :type '(list + (cons :tag "Opening quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")) + (cons :tag "Closing quote" + (string :tag "Regexp for char after ") + (string :tag "Replacement quote ")) + (cons :tag "Single quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")))) + + +;;;; Compilation + +(defcustom org-e-latex-pdf-process + '("pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f") + "Commands to process a LaTeX file to a PDF file. +This is a list of strings, each of them will be given to the +shell as a command. %f in the command will be replaced by the +full file name, %b by the file base name \(i.e. without +extension) and %o by the base directory of the file. + +The reason why this is a list is that it usually takes several +runs of `pdflatex', maybe mixed with a call to `bibtex'. Org +does not have a clever mechanism to detect which of these +commands have to be run to get to a stable result, and it also +does not do any error checking. + +By default, Org uses 3 runs of `pdflatex' to do the processing. +If you have texi2dvi on your system and if that does not cause +the infamous egrep/locale bug: + + http://lists.gnu.org/archive/html/bug-texinfo/2010-03/msg00031.html + +then `texi2dvi' is the superior choice. Org does offer it as one +of the customize options. + +Alternatively, this may be a Lisp function that does the +processing, so you could use this to apply the machinery of +AUCTeX or the Emacs LaTeX mode. This function should accept the +file name as its single argument." + :group 'org-export-pdf + :type '(choice + (repeat :tag "Shell command sequence" + (string :tag "Shell command")) + (const :tag "2 runs of pdflatex" + ("pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f")) + (const :tag "3 runs of pdflatex" + ("pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f")) + (const :tag "pdflatex,bibtex,pdflatex,pdflatex" + ("pdflatex -interaction nonstopmode -output-directory %o %f" + "bibtex %b" + "pdflatex -interaction nonstopmode -output-directory %o %f" + "pdflatex -interaction nonstopmode -output-directory %o %f")) + (const :tag "texi2dvi" + ("texi2dvi -p -b -c -V %f")) + (const :tag "rubber" + ("rubber -d --into %o %f")) + (function))) + +(defcustom org-e-latex-logfiles-extensions + '("aux" "idx" "log" "out" "toc" "nav" "snm" "vrb") + "The list of file extensions to consider as LaTeX logfiles." + :group 'org-export-e-latex + :type '(repeat (string :tag "Extension"))) + +(defcustom org-e-latex-remove-logfiles t + "Non-nil means remove the logfiles produced by PDF production. +These are the .aux, .log, .out, and .toc files." + :group 'org-export-e-latex + :type 'boolean) + + + +;;; Internal Functions + +(defun org-e-latex--caption/label-string (caption label info) + "Return caption and label LaTeX string for floats. + +CAPTION is a cons cell of secondary strings, the car being the +standard caption and the cdr its short form. LABEL is a string +representing the label. INFO is a plist holding contextual +information. + +If there's no caption nor label, return the empty string. + +For non-floats, see `org-e-latex--wrap-label'." + (let ((label-str (if label (format "\\label{%s}" label) ""))) + (cond + ((and (not caption) (not label)) "") + ((not caption) (format "\\label{%s}\n" label)) + ;; Option caption format with short name. + ((cdr caption) + (format "\\caption[%s]{%s%s}\n" + (org-export-data (cdr caption) info) + label-str + (org-export-data (car caption) info))) + ;; Standard caption format. + (t (format "\\caption{%s%s}\n" + label-str + (org-export-data (car caption) info)))))) + +(defun org-e-latex--guess-babel-language (header info) + "Set Babel's language according to LANGUAGE keyword. + +HEADER is the LaTeX header string. INFO is the plist used as +a communication channel. + +Insertion of guessed language only happens when Babel package has +explicitly been loaded. Then it is added to the rest of +package's options. + +Return the new header." + (let ((language-code (plist-get info :language))) + ;; If no language is set or Babel package is not loaded, return + ;; HEADER as-is. + (if (or (not (stringp language-code)) + (not (string-match "\\\\usepackage\\[\\(.*\\)\\]{babel}" header))) + header + (let ((options (save-match-data + (org-split-string (match-string 1 header) ","))) + (language (cdr (assoc language-code + org-e-latex-babel-language-alist)))) + ;; If LANGUAGE is already loaded, return header. Otherwise, + ;; append LANGUAGE to other options. + (if (member language options) header + (replace-match (mapconcat 'identity + (append options (list language)) + ",") + nil nil header 1)))))) + +(defun org-e-latex--guess-inputenc (header) + "Set the coding system in inputenc to what the buffer is. +HEADER is the LaTeX header string. Return the new header." + (let* ((cs (or (ignore-errors + (latexenc-coding-system-to-inputenc + buffer-file-coding-system)) + "utf8"))) + (if (not cs) header + ;; First translate if that is requested. + (setq cs (or (cdr (assoc cs org-e-latex-inputenc-alist)) cs)) + ;; Then find the \usepackage statement and replace the option. + (replace-regexp-in-string "\\\\usepackage\\[\\(AUTO\\)\\]{inputenc}" + cs header t nil 1)))) + +(defun org-e-latex--find-verb-separator (s) + "Return a character not used in string S. +This is used to choose a separator for constructs like \\verb." + (let ((ll "~,./?;':\"|!@#%^&-_=+abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ<>()[]{}")) + (loop for c across ll + when (not (string-match (regexp-quote (char-to-string c)) s)) + return (char-to-string c)))) + +(defun org-e-latex--make-option-string (options) + "Return a comma separated string of keywords and values. +OPTIONS is an alist where the key is the options keyword as +a string, and the value a list containing the keyword value, or +nil." + (mapconcat (lambda (pair) + (concat (first pair) + (when (> (length (second pair)) 0) + (concat "=" (second pair))))) + options + ",")) + +(defun org-e-latex--quotation-marks (text info) + "Export quotation marks depending on language conventions. +TEXT is a string containing quotation marks to be replaced. INFO +is a plist used as a communication channel." + (mapc (lambda(l) + (let ((start 0)) + (while (setq start (string-match (car l) text start)) + (let ((new-quote (concat (match-string 1 text) (cdr l)))) + (setq text (replace-match new-quote t t text)))))) + (cdr (or (assoc (plist-get info :language) org-e-latex-quotes) + ;; Falls back on English. + (assoc "en" org-e-latex-quotes)))) + text) + +(defun org-e-latex--wrap-label (element output) + "Wrap label associated to ELEMENT around OUTPUT, if appropriate. +This function shouldn't be used for floats. See +`org-e-latex--caption/label-string'." + (let ((label (org-element-property :name element))) + (if (or (not output) (not label) (string= output "") (string= label "")) + output + (concat (format "\\label{%s}\n" label) output)))) + +(defun org-e-latex--text-markup (text markup) + "Format TEXT depending on MARKUP text markup. +See `org-e-latex-text-markup-alist' for details." + (let ((fmt (cdr (assq markup org-e-latex-text-markup-alist)))) + (cond + ;; No format string: Return raw text. + ((not fmt) text) + ;; Handle the `verb' special case: Find and appropriate separator + ;; and use "\\verb" command. + ((eq 'verb fmt) + (let ((separator (org-e-latex--find-verb-separator text))) + (concat "\\verb" separator text separator))) + ;; Handle the `protectedtexttt' special case: Protect some + ;; special chars and use "\texttt{%s}" format string. + ((eq 'protectedtexttt fmt) + (let ((start 0) + (trans '(("\\" . "\\textbackslash{}") + ("~" . "\\textasciitilde{}") + ("^" . "\\textasciicircum{}"))) + (rtn "") + char) + (while (string-match "[\\{}$%&_#~^]" text) + (setq char (match-string 0 text)) + (if (> (match-beginning 0) 0) + (setq rtn (concat rtn (substring text 0 (match-beginning 0))))) + (setq text (substring text (1+ (match-beginning 0)))) + (setq char (or (cdr (assoc char trans)) (concat "\\" char)) + rtn (concat rtn char))) + (setq text (concat rtn text) + fmt "\\texttt{%s}") + (while (string-match "--" text) + (setq text (replace-match "-{}-" t t text))) + (format fmt text))) + ;; Else use format string. + (t (format fmt text))))) + +(defun org-e-latex--delayed-footnotes-definitions (element info) + "Return footnotes definitions in ELEMENT as a string. + +INFO is a plist used as a communication channel. + +Footnotes definitions are returned within \"\\footnotetxt{}\" +commands. + +This function is used within constructs that don't support +\"\\footnote{}\" command (i.e. an item's tag). In that case, +\"\\footnotemark\" is used within the construct and the function +just outside of it." + (mapconcat + (lambda (ref) + (format + "\\footnotetext[%s]{%s}" + (org-export-get-footnote-number ref info) + (org-trim + (org-export-data + (org-export-get-footnote-definition ref info) info)))) + ;; Find every footnote reference in ELEMENT. + (let* (all-refs + search-refs ; For byte-compiler. + (search-refs + (function + (lambda (data) + ;; Return a list of all footnote references never seen + ;; before in DATA. + (org-element-map + data 'footnote-reference + (lambda (ref) + (when (org-export-footnote-first-reference-p ref info) + (push ref all-refs) + (when (eq (org-element-property :type ref) 'standard) + (funcall search-refs + (org-export-get-footnote-definition ref info))))) + info) + (reverse all-refs))))) + (funcall search-refs element)) + "")) + + + +;;; Template + +(defun org-e-latex-template (contents info) + "Return complete document string after LaTeX conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (let ((title (org-export-data (plist-get info :title) info))) + (concat + ;; Time-stamp. + (and (plist-get info :time-stamp-file) + (format-time-string "%% Created %Y-%m-%d %a %H:%M\n")) + ;; Document class and packages. + (let ((class (plist-get info :latex-class)) + (class-options (plist-get info :latex-class-options))) + (org-element-normalize-string + (let* ((header (nth 1 (assoc class org-e-latex-classes))) + (document-class-string + (and (stringp header) + (if class-options + (replace-regexp-in-string + "^[ \t]*\\\\documentclass\\(\\[.*?\\]\\)" + class-options header t nil 1) + header)))) + (when document-class-string + (org-e-latex--guess-babel-language + (org-e-latex--guess-inputenc + (org-splice-latex-header + document-class-string + org-export-latex-default-packages-alist ; defined in org.el + org-export-latex-packages-alist nil ; defined in org.el + (plist-get info :latex-header-extra))) + info))))) + ;; Possibly limit depth for headline numbering. + (let ((sec-num (plist-get info :section-numbers))) + (when (integerp sec-num) + (format "\\setcounter{secnumdepth}{%d}\n" sec-num))) + ;; Author. + (let ((author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (email (and (plist-get info :with-email) + (org-export-data (plist-get info :email) info)))) + (cond ((and author email (not (string= "" email))) + (format "\\author{%s\\thanks{%s}}\n" author email)) + (author (format "\\author{%s}\n" author)) + (t "\\author{}\n"))) + ;; Date. + (let ((date (org-export-data (plist-get info :date) info))) + (and date (format "\\date{%s}\n" date))) + ;; Title + (format "\\title{%s}\n" title) + ;; Hyperref options. + (format "\\hypersetup{\n pdfkeywords={%s},\n pdfsubject={%s},\n pdfcreator={%s}}\n" + (or (plist-get info :keywords) "") + (or (plist-get info :description) "") + (if (not (plist-get info :with-creator)) "" + (plist-get info :creator))) + ;; Document start. + "\\begin{document}\n\n" + ;; Title command. + (org-element-normalize-string + (cond ((string= "" title) nil) + ((not (stringp org-e-latex-title-command)) nil) + ((string-match "\\(?:[^%]\\|^\\)%s" + org-e-latex-title-command) + (format org-e-latex-title-command title)) + (t org-e-latex-title-command))) + ;; Table of contents. + (let ((depth (plist-get info :with-toc))) + (when depth + (concat (when (wholenump depth) + (format "\\setcounter{tocdepth}{%d}\n" depth)) + "\\tableofcontents\n\\vspace*{1cm}\n\n"))) + ;; Document's body. + contents + ;; Creator. + (let ((creator-info (plist-get info :with-creator))) + (cond + ((not creator-info) "") + ((eq creator-info 'comment) + (format "%% %s\n" (plist-get info :creator))) + (t (concat (plist-get info :creator) "\n")))) + ;; Document end. + "\\end{document}"))) + + + +;;; Transcode Functions + +;;;; Babel Call +;; +;; Babel Calls are ignored. + + +;;;; Bold + +(defun org-e-latex-bold (bold contents info) + "Transcode BOLD from Org to LaTeX. +CONTENTS is the text with bold markup. INFO is a plist holding +contextual information." + (org-e-latex--text-markup contents 'bold)) + + +;;;; Center Block + +(defun org-e-latex-center-block (center-block contents info) + "Transcode a CENTER-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the center block. INFO is a plist +holding contextual information." + (org-e-latex--wrap-label + center-block + (format "\\begin{center}\n%s\\end{center}" contents))) + + +;;;; Clock + +(defun org-e-latex-clock (clock contents info) + "Transcode a CLOCK element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + (concat + "\\noindent" + (format "\\textbf{%s} " org-clock-string) + (format org-e-latex-inactive-timestamp-format + (concat (org-translate-time (org-element-property :value clock)) + (let ((time (org-element-property :time clock))) + (and time (format " (%s)" time))))) + "\\\\")) + + +;;;; Code + +(defun org-e-latex-code (code contents info) + "Transcode a CODE object from Org to LaTeX. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (org-e-latex--text-markup (org-element-property :value code) 'code)) + + +;;;; Comment +;; +;; Comments are ignored. + + +;;;; Comment Block +;; +;; Comment Blocks are ignored. + + +;;;; Drawer + +(defun org-e-latex-drawer (drawer contents info) + "Transcode a DRAWER element from Org to LaTeX. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let* ((name (org-element-property :drawer-name drawer)) + (output (if (functionp org-e-latex-format-drawer-function) + (funcall org-e-latex-format-drawer-function + name contents) + ;; If there's no user defined function: simply + ;; display contents of the drawer. + contents))) + (org-e-latex--wrap-label drawer output))) + + +;;;; Dynamic Block + +(defun org-e-latex-dynamic-block (dynamic-block contents info) + "Transcode a DYNAMIC-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information. See `org-export-data'." + (org-e-latex--wrap-label dynamic-block contents)) + + +;;;; Entity + +(defun org-e-latex-entity (entity contents info) + "Transcode an ENTITY object from Org to LaTeX. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + (let ((ent (org-element-property :latex entity))) + (if (org-element-property :latex-math-p entity) (format "$%s$" ent) ent))) + + +;;;; Example Block + +(defun org-e-latex-example-block (example-block contents info) + "Transcode an EXAMPLE-BLOCK element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + (org-e-latex--wrap-label + example-block + (format "\\begin{verbatim}\n%s\\end{verbatim}" + (org-export-format-code-default example-block info)))) + + +;;;; Export Block + +(defun org-e-latex-export-block (export-block contents info) + "Transcode a EXPORT-BLOCK element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (string= (org-element-property :type export-block) "LATEX") + (org-remove-indentation (org-element-property :value export-block)))) + + +;;;; Export Snippet + +(defun org-e-latex-export-snippet (export-snippet contents info) + "Transcode a EXPORT-SNIPPET object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (eq (org-export-snippet-backend export-snippet) 'e-latex) + (org-element-property :value export-snippet))) + + +;;;; Fixed Width + +(defun org-e-latex-fixed-width (fixed-width contents info) + "Transcode a FIXED-WIDTH element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-latex--wrap-label + fixed-width + (format "\\begin{verbatim}\n%s\\end{verbatim}" + (org-remove-indentation + (org-element-property :value fixed-width))))) + + +;;;; Footnote Definition +;; +;; Footnote Definitions are ignored. + + +;;;; Footnote Reference +;; +;; Footnote reference export is handled by +;; `org-e-latex-footnote-reference'. +;; +;; Internally, `org-e-latex--get-footnote-counter' is used to restore +;; the value of the LaTeX "footnote" counter after a jump due to +;; a reference to an already defined footnote. It is only needed in +;; item tags since the optional argument to \footnotemark is not +;; allowed there. + +(defun org-e-latex--get-footnote-counter (footnote-reference info) + "Return \"footnote\" counter before FOOTNOTE-REFERENCE is encountered. +INFO is a plist used as a communication channel." + ;; Find original counter value by counting number of footnote + ;; references appearing for the first time before the current + ;; footnote reference. + (let* ((label (org-element-property :label footnote-reference)) + seen-refs + search-ref ; For byte-compiler. + (search-ref + (function + (lambda (data) + ;; Search footnote references through DATA, filling + ;; SEEN-REFS along the way. + (org-element-map + data 'footnote-reference + (lambda (fn) + (let ((fn-lbl (org-element-property :label fn))) + (cond + ;; Anonymous footnote match: return number. + ((eq fn footnote-reference) (length seen-refs)) + ;; Anonymous footnote: it's always a new one. + ;; Also, be sure to return nil from the `cond' so + ;; `first-match' doesn't get us out of the loop. + ((not fn-lbl) (push 'inline seen-refs) nil) + ;; Label not seen so far: add it so SEEN-REFS. + ;; + ;; Also search for subsequent references in + ;; footnote definition so numbering follows reading + ;; logic. Note that we don't have to care about + ;; inline definitions, since `org-element-map' + ;; already traverse them at the right time. + ((not (member fn-lbl seen-refs)) + (push fn-lbl seen-refs) + (funcall search-ref + (org-export-get-footnote-definition fn info)))))) + ;; Don't enter footnote definitions since it will happen + ;; when their first reference is found. + info 'first-match 'footnote-definition))))) + (funcall search-ref (plist-get info :parse-tree)))) + +(defun org-e-latex-footnote-reference (footnote-reference contents info) + "Transcode a FOOTNOTE-REFERENCE element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (concat + ;; Insert separator between two footnotes in a row. + (let ((prev (org-export-get-previous-element footnote-reference info))) + (when (eq (org-element-type prev) 'footnote-reference) + org-e-latex-footnote-separator)) + (cond + ;; Use \footnotemark if reference is within an item's tag. + ((eq (org-element-type (org-export-get-parent-element footnote-reference)) + 'item) + (if (org-export-footnote-first-reference-p footnote-reference info) + "\\footnotemark" + ;; Since we can't specify footnote number as an optional + ;; argument within an item tag, some extra work has to be done + ;; when the footnote has already been referenced. In that + ;; case, set footnote counter to the desired number, use the + ;; footnotemark, then set counter back to its original value. + (format + "\\setcounter{footnote}{%s}\\footnotemark\\setcounter{footnote}{%s}" + (1- (org-export-get-footnote-number footnote-reference info)) + (org-e-latex--get-footnote-counter footnote-reference info)))) + ;; Use \footnotemark if the footnote has already been defined. + ((not (org-export-footnote-first-reference-p footnote-reference info)) + (format "\\footnotemark[%s]{}" + (org-export-get-footnote-number footnote-reference info))) + ;; Use \footnotemark if reference is within another footnote + ;; reference or footnote definition. + ((loop for parent in (org-export-get-genealogy footnote-reference) + thereis (memq (org-element-type parent) + '(footnote-reference footnote-definition))) + "\\footnotemark") + ;; Otherwise, define it with \footnote command. + (t + (let ((def (org-export-get-footnote-definition footnote-reference info))) + (unless (eq (org-element-type def) 'org-data) + (setq def (cons 'org-data (cons nil def)))) + (concat + (format "\\footnote{%s}" (org-trim (org-export-data def info))) + ;; Retrieve all footnote references within the footnote and + ;; add their definition after it, since LaTeX doesn't support + ;; them inside. + (org-e-latex--delayed-footnotes-definitions def info))))))) + + +;;;; Headline + +(defun org-e-latex-headline (headline contents info) + "Transcode an HEADLINE element from Org to LaTeX. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((class (plist-get info :latex-class)) + (level (org-export-get-relative-level headline info)) + (numberedp (org-export-numbered-headline-p headline info)) + (class-sectionning (assoc class org-e-latex-classes)) + ;; Section formatting will set two placeholders: one for the + ;; title and the other for the contents. + (section-fmt + (let ((sec (if (and (symbolp (nth 2 class-sectionning)) + (fboundp (nth 2 class-sectionning))) + (funcall (nth 2 class-sectionning) level numberedp) + (nth (1+ level) class-sectionning)))) + (cond + ;; No section available for that LEVEL. + ((not sec) nil) + ;; Section format directly returned by a function. + ((stringp sec) sec) + ;; (numbered-section . unnumbered-section) + ((not (consp (cdr sec))) + (concat (funcall (if numberedp #'car #'cdr) sec) "\n%s")) + ;; (numbered-open numbered-close) + ((= (length sec) 2) + (when numberedp (concat (car sec) "\n%s" (nth 1 sec)))) + ;; (num-in num-out no-num-in no-num-out) + ((= (length sec) 4) + (if numberedp (concat (car sec) "\n%s" (nth 1 sec)) + (concat (nth 2 sec) "\n%s" (nth 3 sec))))))) + (text (org-export-data (org-element-property :title headline) info)) + (todo + (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + ;; Create the headline text along with a no-tag version. The + ;; latter is required to remove tags from table of contents. + (full-text (if (functionp org-e-latex-format-headline-function) + ;; User-defined formatting function. + (funcall org-e-latex-format-headline-function + todo todo-type priority text tags) + ;; Default formatting. + (concat + (when todo + (format "\\textbf{\\textsf{\\textsc{%s}}} " todo)) + (when priority (format "\\framebox{\\#%c} " priority)) + text + (when tags + (format "\\hfill{}\\textsc{:%s:}" + (mapconcat 'identity tags ":")))))) + (full-text-no-tag + (if (functionp org-e-latex-format-headline-function) + ;; User-defined formatting function. + (funcall org-e-latex-format-headline-function + todo todo-type priority text nil) + ;; Default formatting. + (concat + (when todo (format "\\textbf{\\textsf{\\textsc{%s}}} " todo)) + (when priority (format "\\framebox{\\#%c} " priority)) + text))) + ;; Associate some \label to the headline for internal links. + (headline-label + (format "\\label{sec-%s}\n" + (mapconcat 'number-to-string + (org-export-get-headline-number headline info) + "-"))) + (pre-blanks + (make-string (org-element-property :pre-blank headline) 10))) + (cond + ;; Case 1: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + ;; Case 2. This is a deep sub-tree: export it as a list item. + ;; Also export as items headlines for which no section + ;; format has been found. + ((or (not section-fmt) (org-export-low-level-p headline info)) + ;; Build the real contents of the sub-tree. + (let ((low-level-body + (concat + ;; If the headline is the first sibling, start a list. + (when (org-export-first-sibling-p headline info) + (format "\\begin{%s}\n" (if numberedp 'enumerate 'itemize))) + ;; Itemize headline + "\\item " full-text "\n" headline-label pre-blanks contents))) + ;; If headline is not the last sibling simply return + ;; LOW-LEVEL-BODY. Otherwise, also close the list, before any + ;; blank line. + (if (not (org-export-last-sibling-p headline info)) low-level-body + (replace-regexp-in-string + "[ \t\n]*\\'" + (format "\n\\\\end{%s}" (if numberedp 'enumerate 'itemize)) + low-level-body)))) + ;; Case 3. Standard headline. Export it as a section. + (t + (cond + ((not (and tags (eq (plist-get info :with-tags) 'not-in-toc))) + ;; Regular section. Use specified format string. + (format section-fmt full-text + (concat headline-label pre-blanks contents))) + ((string-match "\\`\\\\\\(.*?\\){" section-fmt) + ;; If tags should be removed from table of contents, insert + ;; title without tags as an alternative heading in sectioning + ;; command. + (format (replace-match (concat (match-string 1 section-fmt) "[%s]") + nil nil section-fmt 1) + ;; Replace square brackets with parenthesis since + ;; square brackets are not supported in optional + ;; arguments. + (replace-regexp-in-string + "\\[" "(" + (replace-regexp-in-string + "\\]" ")" + full-text-no-tag)) + full-text + (concat headline-label pre-blanks contents))) + (t + ;; Impossible to add an alternative heading. Fallback to + ;; regular sectioning format string. + (format section-fmt full-text + (concat headline-label pre-blanks contents)))))))) + + +;;;; Horizontal Rule + +(defun org-e-latex-horizontal-rule (horizontal-rule contents info) + "Transcode an HORIZONTAL-RULE object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((attr (org-export-read-attribute :attr_latex horizontal-rule)) + (prev (org-export-get-previous-element horizontal-rule info))) + (concat + ;; Make sure the rule doesn't start at the end of the current + ;; line by separating it with a blank line from previous element. + (when (and prev + (let ((prev-blank (org-element-property :post-blank prev))) + (or (not prev-blank) (zerop prev-blank)))) + "\n") + (org-e-latex--wrap-label + horizontal-rule + (format "\\rule{%s}{%s}" + (or (plist-get attr :width) "\\linewidth") + (or (plist-get attr :thickness) "0.5pt")))))) + + +;;;; Inline Babel Call +;; +;; Inline Babel Calls are ignored. + + +;;;; Inline Src Block + +(defun org-e-latex-inline-src-block (inline-src-block contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((code (org-element-property :value inline-src-block)) + (separator (org-e-latex--find-verb-separator code))) + (cond + ;; Do not use a special package: transcode it verbatim. + ((not org-e-latex-listings) + (concat "\\verb" separator code separator)) + ;; Use minted package. + ((eq org-e-latex-listings 'minted) + (let* ((org-lang (org-element-property :language inline-src-block)) + (mint-lang (or (cadr (assq (intern org-lang) + org-e-latex-minted-langs)) + org-lang)) + (options (org-e-latex--make-option-string + org-e-latex-minted-options))) + (concat (format "\\mint%s{%s}" + (if (string= options "") "" (format "[%s]" options)) + mint-lang) + separator code separator))) + ;; Use listings package. + (t + ;; Maybe translate language's name. + (let* ((org-lang (org-element-property :language inline-src-block)) + (lst-lang (or (cadr (assq (intern org-lang) + org-e-latex-listings-langs)) + org-lang)) + (options (org-e-latex--make-option-string + (append org-e-latex-listings-options + `(("language" ,lst-lang)))))) + (concat (format "\\lstinline[%s]" options) + separator code separator)))))) + + +;;;; Inlinetask + +(defun org-e-latex-inlinetask (inlinetask contents info) + "Transcode an INLINETASK element from Org to LaTeX. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((title (org-export-data (org-element-property :title inlinetask) info)) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword inlinetask))) + (and todo (org-export-data todo info))))) + (todo-type (org-element-property :todo-type inlinetask)) + (tags (and (plist-get info :with-tags) + (org-export-get-tags inlinetask info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority inlinetask)))) + ;; If `org-e-latex-format-inlinetask-function' is provided, call it + ;; with appropriate arguments. + (if (functionp org-e-latex-format-inlinetask-function) + (funcall org-e-latex-format-inlinetask-function + todo todo-type priority title tags contents) + ;; Otherwise, use a default template. + (org-e-latex--wrap-label + inlinetask + (let ((full-title + (concat + (when todo (format "\\textbf{\\textsf{\\textsc{%s}}} " todo)) + (when priority (format "\\framebox{\\#%c} " priority)) + title + (when tags (format "\\hfill{}\\textsc{:%s:}" + (mapconcat 'identity tags ":")))))) + (format (concat "\\begin{center}\n" + "\\fbox{\n" + "\\begin{minipage}[c]{.6\\textwidth}\n" + "%s\n\n" + "\\rule[.8em]{\\textwidth}{2pt}\n\n" + "%s" + "\\end{minipage}\n" + "}\n" + "\\end{center}") + full-title contents)))))) + + +;;;; Italic + +(defun org-e-latex-italic (italic contents info) + "Transcode ITALIC from Org to LaTeX. +CONTENTS is the text with italic markup. INFO is a plist holding +contextual information." + (org-e-latex--text-markup contents 'italic)) + + +;;;; Item + +(defun org-e-latex-item (item contents info) + "Transcode an ITEM element from Org to LaTeX. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((counter + (let ((count (org-element-property :counter item)) + (level + (loop for parent in (org-export-get-genealogy item) + count (eq (org-element-type parent) 'plain-list) + until (eq (org-element-type parent) 'headline)))) + (and count + (< level 5) + (format "\\setcounter{enum%s}{%s}\n" + (nth (1- level) '("i" "ii" "iii" "iv")) + (1- count))))) + (checkbox (case (org-element-property :checkbox item) + (on "$\\boxtimes$ ") + (off "$\\Box$ ") + (trans "$\\boxminus$ "))) + (tag (let ((tag (org-element-property :tag item))) + ;; Check-boxes must belong to the tag. + (and tag (format "[%s] " + (concat checkbox + (org-export-data tag info))))))) + (concat counter "\\item" (or tag (concat " " checkbox)) + (and contents (org-trim contents)) + ;; If there are footnotes references in tag, be sure to + ;; add their definition at the end of the item. This + ;; workaround is necessary since "\footnote{}" command is + ;; not supported in tags. + (and tag + (org-e-latex--delayed-footnotes-definitions + (org-element-property :tag item) info))))) + + +;;;; Keyword + +(defun org-e-latex-keyword (keyword contents info) + "Transcode a KEYWORD element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + (cond + ((string= key "LATEX") value) + ((string= key "INDEX") (format "\\index{%s}" value)) + ;; Invisible targets. + ((string= key "TARGET") nil) + ((string= key "TOC") + (let ((value (downcase value))) + (cond + ((string-match "\\<headlines\\>" value) + (let ((depth (or (and (string-match "[0-9]+" value) + (string-to-number (match-string 0 value))) + (plist-get info :with-toc)))) + (concat + (when (wholenump depth) + (format "\\setcounter{tocdepth}{%s}\n" depth)) + "\\tableofcontents"))) + ((string= "tables" value) "\\listoftables") + ((string= "figures" value) "\\listoffigures") + ((string= "listings" value) + (cond + ((eq org-e-latex-listings 'minted) "\\listoflistings") + (org-e-latex-listings "\\lstlistoflistings") + ;; At the moment, src blocks with a caption are wrapped + ;; into a figure environment. + (t "\\listoffigures"))))))))) + + +;;;; Latex Environment + +(defun org-e-latex-latex-environment (latex-environment contents info) + "Transcode a LATEX-ENVIRONMENT element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((label (org-element-property :name latex-environment)) + (value (org-remove-indentation + (org-element-property :value latex-environment)))) + (if (not (org-string-nw-p label)) value + ;; Environment is labelled: label must be within the environment + ;; (otherwise, a reference pointing to that element will count + ;; the section instead). + (with-temp-buffer + (insert value) + (goto-char (point-min)) + (forward-line) + (insert (format "\\label{%s}\n" label)) + (buffer-string))))) + + +;;;; Latex Fragment + +(defun org-e-latex-latex-fragment (latex-fragment contents info) + "Transcode a LATEX-FRAGMENT object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-element-property :value latex-fragment)) + + +;;;; Line Break + +(defun org-e-latex-line-break (line-break contents info) + "Transcode a LINE-BREAK object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + "\\\\") + + +;;;; Link + +(defun org-e-latex-link--inline-image (link info) + "Return LaTeX code for an inline image. +LINK is the link pointing to the inline image. INFO is a plist +used as a communication channel." + (let* ((parent (org-export-get-parent-element link)) + (path (let ((raw-path (org-element-property :path link))) + (if (not (file-name-absolute-p raw-path)) raw-path + (expand-file-name raw-path)))) + (caption (org-e-latex--caption/label-string + (org-element-property :caption parent) + (org-element-property :name parent) + info)) + ;; Retrieve latex attributes from the element around. + (attr (let ((raw-attr + (mapconcat #'identity + (org-element-property :attr_latex parent) + " "))) + (unless (string= raw-attr "") raw-attr))) + (disposition + (cond + ((and attr (string-match "\\<wrap\\>" attr)) 'wrap) + ((and attr (string-match "\\<multicolumn\\>" attr)) 'multicolumn) + ((or (and attr (string-match "\\<float\\>" attr)) + (not (string= caption ""))) + 'float))) + (placement + (cond + ((and attr (string-match "\\<placement=\\(\\S-+\\)" attr)) + (org-match-string-no-properties 1 attr)) + ((eq disposition 'wrap) "{l}{0.5\\textwidth}") + ((eq disposition 'float) + (concat "[" org-e-latex-default-figure-position "]")) + (t "")))) + ;; Now clear ATTR from any special keyword and set a default + ;; value if nothing is left. + (setq attr + (if (not attr) "" + (org-trim + (replace-regexp-in-string + "\\(wrap\\|multicolumn\\|float\\|placement=\\S-+\\)" "" attr)))) + (setq attr (cond ((not (string= attr "")) attr) + ((eq disposition 'float) "width=0.7\\textwidth") + ((eq disposition 'wrap) "width=0.48\\textwidth") + (t (or org-e-latex-image-default-option "")))) + ;; Return proper string, depending on DISPOSITION. + (case disposition + (wrap (format "\\begin{wrapfigure}%s +\\centering +\\includegraphics[%s]{%s} +%s\\end{wrapfigure}" placement attr path caption)) + (multicolumn (format "\\begin{figure*}%s +\\centering +\\includegraphics[%s]{%s} +%s\\end{figure*}" placement attr path caption)) + (float (format "\\begin{figure}%s +\\centering +\\includegraphics[%s]{%s} +%s\\end{figure}" placement attr path caption)) + (t (format "\\includegraphics[%s]{%s}" attr path))))) + +(defun org-e-latex-link (link desc info) + "Transcode a LINK object from Org to LaTeX. + +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-latex-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-latex-link--inline-image link info)) + ;; 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 "\\hyperref[%s]{%s}" + (org-export-solidify-link-text path) + (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 + (if desc (format "\\href{file://%s}{%s}" destination desc) + (format "\\url{file://%s}" destination))) + ;; Fuzzy link points nowhere. + ('nil + (format org-e-latex-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 + (format "sec-%s" + (mapconcat + 'number-to-string + (org-export-get-headline-number destination info) + "-")))) + (if (and (plist-get info :section-numbers) (not desc)) + (format "\\ref{%s}" label) + (format "\\hyperref[%s]{%s}" label + (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 "\\ref{%s}" path) + (format "\\hyperref[%s]{%s}" path desc))))))) + ;; Coderef: replace link with the reference name or the + ;; equivalent line number. + ((string= type "coderef") + (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 'latex)) + ;; External link with a description part. + ((and path desc) (format "\\href{%s}{%s}" path desc)) + ;; External link without a description part. + (path (format "\\url{%s}" path)) + ;; No path, only description. Try to do something useful. + (t (format org-e-latex-link-with-unknown-path-format desc))))) + + +;;;; Macro + +(defun org-e-latex-macro (macro contents info) + "Transcode a MACRO element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + ;; Use available tools. + (org-export-expand-macro macro info)) + + +;;;; Paragraph + +(defun org-e-latex-paragraph (paragraph contents info) + "Transcode a PARAGRAPH element from Org to LaTeX. +CONTENTS is the contents of the paragraph, as a string. INFO is +the plist used as a communication channel." + contents) + + +;;;; Plain List + +(defun org-e-latex-plain-list (plain-list contents info) + "Transcode a PLAIN-LIST element from Org to LaTeX. +CONTENTS is the contents of the list. INFO is a plist holding +contextual information." + (let* ((type (org-element-property :type plain-list)) + (paralist-types '("inparaenum" "asparaenum" "inparaitem" "asparaitem" + "inparadesc" "asparadesc")) + (paralist-regexp (concat + "\\(" + (mapconcat 'identity paralist-types "\\|") + "\\)")) + (attr (mapconcat #'identity + (org-element-property :attr_latex plain-list) + " ")) + (latex-type (cond + ((and attr + (string-match + (format "\\<%s\\>" paralist-regexp) attr)) + (match-string 1 attr)) + ((eq type 'ordered) "enumerate") + ((eq type 'unordered) "itemize") + ((eq type 'descriptive) "description")))) + (org-e-latex--wrap-label + plain-list + (format "\\begin{%s}%s\n%s\\end{%s}" + latex-type + ;; Once special environment, if any, has been removed, the + ;; rest of the attributes will be optional arguments. + ;; They will be put inside square brackets if necessary. + (let ((opt (replace-regexp-in-string + (format " *%s *" paralist-regexp) "" attr))) + (cond ((string= opt "") "") + ((string-match "\\`\\[[^][]+\\]\\'" opt) opt) + (t (format "[%s]" opt)))) + contents + latex-type)))) + + +;;;; Plain Text + +(defun org-e-latex-plain-text (text info) + "Transcode a TEXT string from Org to LaTeX. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; Protect %, #, &, $, ~, ^, _, { and }. + (while (string-match "\\([^\\]\\|^\\)\\([%$#&{}~^_]\\)" text) + (setq text + (replace-match (format "\\%s" (match-string 2 text)) nil t text 2))) + ;; Protect \ + (setq text (replace-regexp-in-string + "\\(?:[^\\]\\|^\\)\\(\\\\\\)\\(?:[^%$#&{}~^_\\]\\|$\\)" + "$\\backslash$" text nil t 1)) + ;; LaTeX into \LaTeX{} and TeX into \TeX{}. + (let ((case-fold-search nil) + (start 0)) + (while (string-match "\\<\\(\\(?:La\\)?TeX\\)\\>" text start) + (setq text (replace-match + (format "\\%s{}" (match-string 1 text)) nil t text) + start (match-end 0)))) + ;; Handle quotation marks + (setq text (org-e-latex--quotation-marks text info)) + ;; Convert special strings. + (when (plist-get info :with-special-strings) + (while (string-match (regexp-quote "...") text) + (setq text (replace-match "\\ldots{}" nil t text)))) + ;; Handle break preservation if required. + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" + text))) + ;; Return value. + text) + + +;;;; Planning + +(defun org-e-latex-planning (planning contents info) + "Transcode a PLANNING element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + (concat + "\\noindent" + (mapconcat + 'identity + (delq nil + (list + (let ((closed (org-element-property :closed planning))) + (when closed + (concat + (format "\\textbf{%s} " org-closed-string) + (format org-e-latex-inactive-timestamp-format + (org-translate-time closed))))) + (let ((deadline (org-element-property :deadline planning))) + (when deadline + (concat + (format "\\textbf{%s} " org-deadline-string) + (format org-e-latex-active-timestamp-format + (org-translate-time deadline))))) + (let ((scheduled (org-element-property :scheduled planning))) + (when scheduled + (concat + (format "\\textbf{%s} " org-scheduled-string) + (format org-e-latex-active-timestamp-format + (org-translate-time scheduled))))))) + " ") + "\\\\")) + + +;;;; Property Drawer + +(defun org-e-latex-property-drawer (property-drawer contents info) + "Transcode a PROPERTY-DRAWER element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + ;; The property drawer isn't exported but we want separating blank + ;; lines nonetheless. + "") + + +;;;; Quote Block + +(defun org-e-latex-quote-block (quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (org-e-latex--wrap-label + quote-block + (format "\\begin{quote}\n%s\\end{quote}" contents))) + + +;;;; Quote Section + +(defun org-e-latex-quote-section (quote-section contents info) + "Transcode a QUOTE-SECTION element from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((value (org-remove-indentation + (org-element-property :value quote-section)))) + (when value (format "\\begin{verbatim}\n%s\\end{verbatim}" value)))) + + +;;;; Radio Target + +(defun org-e-latex-radio-target (radio-target text info) + "Transcode a RADIO-TARGET object from Org to LaTeX. +TEXT is the text of the target. INFO is a plist holding +contextual information." + (format "\\label{%s}%s" + (org-export-solidify-link-text + (org-element-property :value radio-target)) + text)) + + +;;;; Section + +(defun org-e-latex-section (section contents info) + "Transcode a SECTION element from Org to LaTeX. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + contents) + + +;;;; Special Block + +(defun org-e-latex-special-block (special-block contents info) + "Transcode a SPECIAL-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((type (downcase (org-element-property :type special-block)))) + (org-e-latex--wrap-label + special-block + (format "\\begin{%s}\n%s\\end{%s}" type contents type)))) + + +;;;; Src Block + +(defun org-e-latex-src-block (src-block contents info) + "Transcode a SRC-BLOCK element from Org to LaTeX. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((lang (org-element-property :language src-block)) + (caption (org-element-property :caption src-block)) + (label (org-element-property :name src-block)) + (custom-env (and lang + (cadr (assq (intern lang) + org-e-latex-custom-lang-environments)))) + (num-start (case (org-element-property :number-lines src-block) + (continued (org-export-get-loc src-block info)) + (new 0))) + (retain-labels (org-element-property :retain-labels src-block))) + (cond + ;; Case 1. No source fontification. + ((not org-e-latex-listings) + (let ((caption-str (org-e-latex--caption/label-string caption label info)) + (float-env (when caption "\\begin{figure}[H]\n%s\n\\end{figure}"))) + (format + (or float-env "%s") + (concat caption-str + (format "\\begin{verbatim}\n%s\\end{verbatim}" + (org-export-format-code-default src-block info)))))) + ;; Case 2. Custom environment. + (custom-env (format "\\begin{%s}\n%s\\end{%s}\n" + custom-env + (org-export-format-code-default src-block info) + custom-env)) + ;; Case 3. Use minted package. + ((eq org-e-latex-listings 'minted) + (let ((float-env (when (or label caption) + (format "\\begin{listing}[H]\n%%s\n%s\\end{listing}" + (org-e-latex--caption/label-string + caption label info)))) + (body + (format + "\\begin{minted}[%s]{%s}\n%s\\end{minted}" + ;; Options. + (org-e-latex--make-option-string + (if (not num-start) org-e-latex-minted-options + (append `(("linenos") + ("firstnumber" ,(number-to-string (1+ num-start)))) + org-e-latex-minted-options))) + ;; Language. + (or (cadr (assq (intern lang) org-e-latex-minted-langs)) lang) + ;; Source code. + (let* ((code-info (org-export-unravel-code src-block)) + (max-width + (apply 'max + (mapcar 'length + (org-split-string (car code-info) "\n"))))) + (org-export-format-code + (car code-info) + (lambda (loc num ref) + (concat + loc + (when ref + ;; Ensure references are flushed to the right, + ;; separated with 6 spaces from the widest line + ;; of code. + (concat (make-string (+ (- max-width (length loc)) 6) ? ) + (format "(%s)" ref))))) + nil (and retain-labels (cdr code-info))))))) + ;; Return value. + (if float-env (format float-env body) body))) + ;; Case 4. Use listings package. + (t + (let ((lst-lang + (or (cadr (assq (intern lang) org-e-latex-listings-langs)) lang)) + (caption-str + (when caption + (let ((main (org-export-data (car caption) info))) + (if (not (cdr caption)) (format "{%s}" main) + (format "{[%s]%s}" + (org-export-data (cdr caption) info) + main)))))) + (concat + ;; Options. + (format "\\lstset{%s}\n" + (org-e-latex--make-option-string + (append org-e-latex-listings-options + `(("language" ,lst-lang)) + (when label `(("label" ,label))) + (when caption-str `(("caption" ,caption-str))) + (cond ((not num-start) '(("numbers" "none"))) + ((zerop num-start) '(("numbers" "left"))) + (t `(("numbers" "left") + ("firstnumber" + ,(number-to-string (1+ num-start))))))))) + ;; Source code. + (format + "\\begin{lstlisting}\n%s\\end{lstlisting}" + (let* ((code-info (org-export-unravel-code src-block)) + (max-width + (apply 'max + (mapcar 'length + (org-split-string (car code-info) "\n"))))) + (org-export-format-code + (car code-info) + (lambda (loc num ref) + (concat + loc + (when ref + ;; Ensure references are flushed to the right, + ;; separated with 6 spaces from the widest line of + ;; code + (concat (make-string (+ (- max-width (length loc)) 6) ? ) + (format "(%s)" ref))))) + nil (and retain-labels (cdr code-info))))))))))) + + +;;;; Statistics Cookie + +(defun org-e-latex-statistics-cookie (statistics-cookie contents info) + "Transcode a STATISTICS-COOKIE object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual information." + (replace-regexp-in-string + "%" "\\%" (org-element-property :value statistics-cookie) nil t)) + + +;;;; Strike-Through + +(defun org-e-latex-strike-through (strike-through contents info) + "Transcode STRIKE-THROUGH from Org to LaTeX. +CONTENTS is the text with strike-through markup. INFO is a plist +holding contextual information." + (org-e-latex--text-markup contents 'strike-through)) + + +;;;; Subscript + +(defun org-e-latex-subscript (subscript contents info) + "Transcode a SUBSCRIPT object from Org to LaTeX. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (if (= (length contents) 1) (format "$_%s$" contents) + ;; Handle multiple objects in SUBSCRIPT by creating a subscript + ;; command for each of them. + (let ((prev-blanks 0)) + (mapconcat + (lambda (obj) + (case (org-element-type obj) + ((entity latex-fragment) + (setq prev-blanks (org-element-property :post-blank obj)) + (let ((data (org-trim (org-export-data obj info)))) + (string-match + "\\`\\(?:\\\\[([]\\|\\$+\\)?\\(.*?\\)\\(?:\\\\[])]\\|\\$+\\)?\\'" + data) + (format "$_{%s}$" (match-string 1 data)))) + (plain-text + (format "$_\\mathrm{%s}$" + (concat (make-string prev-blanks ? ) + ;; mathrm command doesn't handle spaces, + ;; so we have to enforce them. + (replace-regexp-in-string + " " "\\\\ " (org-export-data obj info))))) + (otherwise + (setq prev-blanks (org-element-property :post-blank obj)) + (format "$_{%s}$" (org-export-data obj info))))) + (org-element-contents subscript) "")))) + + +;;;; Superscript + +(defun org-e-latex-superscript (superscript contents info) + "Transcode a SUPERSCRIPT object from Org to LaTeX. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (if (= (length contents) 1) (format "$^%s$" contents) + ;; Handle multiple objects in SUPERSCRIPT by creating + ;; a superscript command for each of them. + (let ((prev-blanks 0)) + (mapconcat + (lambda (obj) + (case (org-element-type obj) + ((entity latex-fragment) + (setq prev-blanks (org-element-property :post-blank obj)) + (let ((data (org-trim (org-export-data obj info)))) + (string-match + "\\`\\(?:\\\\[([]\\|\\$+\\)?\\(.*?\\)\\(?:\\\\[])]\\|\\$+\\)?\\'" + data) + (format "$^{%s}$" (match-string 1 data)))) + (plain-text + (format "$^\\mathrm{%s}$" + (concat (make-string prev-blanks ? ) + ;; mathrm command doesn't handle spaces, + ;; so we have to enforce them. + (replace-regexp-in-string + " " "\\\\ " (org-export-data obj info))))) + (otherwise + (setq prev-blanks (org-element-property :post-blank obj)) + (format "$^{%s}$" (org-export-data obj info))))) + (org-element-contents superscript) "")))) + + +;;;; Table +;; +;; `org-e-latex-table' is the entry point for table transcoding. It +;; takes care of tables with a "verbatim" attribute. Otherwise, it +;; delegates the job to either `org-e-latex-table--table.el-table' or +;; `org-e-latex-table--org-table' functions, depending of the type of +;; the table. +;; +;; `org-e-latex-table--align-string' is a subroutine used to build +;; alignment string for Org tables. + +(defun org-e-latex-table (table contents info) + "Transcode a TABLE element from Org to LaTeX. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (cond + ;; Case 1: verbatim table. + ((or org-e-latex-tables-verbatim + (let ((attr (mapconcat 'identity + (org-element-property :attr_latex table) + " "))) + (and attr (string-match "\\<verbatim\\>" attr)))) + (format "\\begin{verbatim}\n%s\n\\end{verbatim}" + ;; Re-create table, without affiliated keywords. + (org-trim + (org-element-interpret-data + `(table nil ,@(org-element-contents table)))))) + ;; Case 2: table.el table. Convert it using appropriate tools. + ((eq (org-element-property :type table) 'table.el) + (org-e-latex-table--table.el-table table contents info)) + ;; Case 3: Standard table. + (t (org-e-latex-table--org-table table contents info)))) + +(defun org-e-latex-table--align-string (table info) + "Return an appropriate LaTeX alignment string. +TABLE is the considered table. INFO is a plist used as +a communication channel." + (let ((attr (mapconcat 'identity + (org-element-property :attr_latex table) + " "))) + (if (string-match "\\<align=\\(\\S-+\\)" attr) (match-string 1 attr) + (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))) + ;; Check left border for the first cell only. + (when (and (memq 'left borders) (not alignment)) + (push "|" alignment)) + (push (case (org-export-table-cell-alignment cell info) + (left "l") + (right "r") + (center "c")) + alignment) + (when (memq 'right borders) (push "|" alignment)))) + info) + (apply 'concat (reverse alignment)))))) + +(defun org-e-latex-table--org-table (table contents info) + "Return appropriate LaTeX 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-latex--caption/label-string + (org-element-property :caption table) label info)) + (attr (mapconcat 'identity + (org-element-property :attr_latex table) + " ")) + ;; Determine alignment string. + (alignment (org-e-latex-table--align-string table info)) + ;; Determine environment for the table: longtable, tabular... + (table-env (cond + ((not attr) org-e-latex-default-table-environment) + ((string-match "\\<longtable\\>" attr) "longtable") + ((string-match "\\<tabular.?\\>" attr) + (org-match-string-no-properties 0 attr)) + (t org-e-latex-default-table-environment))) + ;; If table is a float, determine environment: table, table* + ;; or sidewaystable. + (float-env (cond + ((string= "longtable" table-env) nil) + ((and attr (string-match "\\<sidewaystable\\>" attr)) + "sidewaystable") + ((and attr + (or (string-match (regexp-quote "table*") attr) + (string-match "\\<multicolumn\\>" attr))) + "table*") + ((or (not (string= caption "")) label) "table"))) + ;; Extract others display options. + (width (and attr (string-match "\\<width=\\(\\S-+\\)" attr) + (org-match-string-no-properties 1 attr))) + (placement + (if (and attr (string-match "\\<placement=\\(\\S-+\\)" attr)) + (org-match-string-no-properties 1 attr) + (format "[%s]" org-e-latex-default-figure-position)))) + ;; Prepare the final format string for the table. + (cond + ;; Longtable. + ((string= "longtable" table-env) + (format + "\\begin{longtable}{%s}\n%s%s%s\\end{longtable}" + alignment + (if (or (not org-e-latex-table-caption-above) (string= "" caption)) "" + (concat (org-trim caption) "\\\\\n")) + contents + (if (or org-e-latex-table-caption-above (string= "" caption)) "" + (concat (org-trim caption) "\\\\\n")))) + ;; Others. + (t (concat (when float-env + (concat + (format "\\begin{%s}%s\n" float-env placement) + (if org-e-latex-table-caption-above caption ""))) + (when org-e-latex-tables-centered "\\begin{center}\n") + (format "\\begin{%s}%s{%s}\n%s\\end{%s}" + table-env + (if width (format "{%s}" width) "") + alignment + contents + table-env) + (when org-e-latex-tables-centered "\n\\end{center}") + (when float-env + (concat (if org-e-latex-table-caption-above "" caption) + (format "\n\\end{%s}" float-env)))))))) + +(defun org-e-latex-table--table.el-table (table contents info) + "Return appropriate LaTeX code for a table.el 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 `table.el' as its `:type' +attribute." + (require 'table) + ;; Ensure "*org-export-table*" buffer is empty. + (with-current-buffer (get-buffer-create "*org-export-table*") + (erase-buffer)) + (let ((output (with-temp-buffer + (insert (org-element-property :value table)) + (goto-char 1) + (re-search-forward "^[ \t]*|[^|]" nil t) + (table-generate-source 'latex "*org-export-table*") + (with-current-buffer "*org-export-table*" + (org-trim (buffer-string)))))) + (kill-buffer (get-buffer "*org-export-table*")) + ;; Remove left out comments. + (while (string-match "^%.*\n" output) + (setq output (replace-match "" t t output))) + ;; When the "rmlines" attribute is provided, remove all hlines but + ;; the the one separating heading from the table body. + (let ((attr (mapconcat 'identity + (org-element-property :attr_latex table) + " "))) + (when (and attr (string-match "\\<rmlines\\>" attr)) + (let ((n 0) (pos 0)) + (while (and (< (length output) pos) + (setq pos (string-match "^\\\\hline\n?" output pos))) + (incf n) + (unless (= n 2) + (setq output (replace-match "" nil nil output))))))) + (if (not org-e-latex-tables-centered) output + (format "\\begin{center}\n%s\n\\end{center}" output)))) + + +;;;; Table Cell + +(defun org-e-latex-table-cell (table-cell contents info) + "Transcode a TABLE-CELL element from Org to LaTeX. +CONTENTS is the cell contents. INFO is a plist used as +a communication channel." + (concat (if (and contents + org-e-latex-table-scientific-notation + (string-match orgtbl-exp-regexp contents)) + ;; Use appropriate format string for scientific + ;; notation. + (format org-e-latex-table-scientific-notation + (match-string 1 contents) + (match-string 2 contents)) + contents) + (when (org-export-get-next-element table-cell info) " & "))) + + +;;;; Table Row + +(defun org-e-latex-table-row (table-row contents info) + "Transcode a TABLE-ROW element from Org to LaTeX. +CONTENTS is the contents of the row. INFO is a plist used as +a communication channel." + ;; Rules are ignored since table separators are deduced from + ;; borders of the current row. + (when (eq (org-element-property :type table-row) 'standard) + (let* ((attr (mapconcat 'identity + (org-element-property + :attr_latex (org-export-get-parent table-row)) + " ")) + (longtablep (and attr (string-match "\\<longtable\\>" attr))) + (booktabsp + (or (and attr (string-match "\\<booktabs=\\(yes\\|t\\)\\>" attr)) + org-e-latex-tables-booktabs)) + ;; TABLE-ROW's borders are extracted from its first cell. + (borders + (org-export-table-cell-borders + (car (org-element-contents table-row)) info))) + (concat + ;; When BOOKTABS are activated enforce top-rule even when no + ;; hline was specifically marked. + (cond ((and booktabsp (memq 'top borders)) "\\toprule\n") + ((and (memq 'top borders) (memq 'above borders)) "\\hline\n")) + contents "\\\\\n" + (cond + ;; Special case for long tables. Define header and footers. + ((and longtablep (org-export-table-row-ends-header-p table-row info)) + (format "%s +\\endhead +%s\\multicolumn{%d}{r}{Continued on next page} \\\\ +\\endfoot +\\endlastfoot" + (if booktabsp "\\midrule" "\\hline") + (if booktabsp "\\midrule" "\\hline") + ;; Number of columns. + (cdr (org-export-table-dimensions + (org-export-get-parent-table table-row) info)))) + ;; When BOOKTABS are activated enforce bottom rule even when + ;; no hline was specifically marked. + ((and booktabsp (memq 'bottom borders)) "\\bottomrule") + ((and (memq 'bottom borders) (memq 'below borders)) "\\hline") + ((memq 'below borders) (if booktabsp "\\midrule" "\\hline"))))))) + + +;;;; Target + +(defun org-e-latex-target (target contents info) + "Transcode a TARGET object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format "\\label{%s}" + (org-export-solidify-link-text (org-element-property :value target)))) + + +;;;; Timestamp + +(defun org-e-latex-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to LaTeX. +CONTENTS is nil. INFO is a plist holding contextual +information." + (let ((value (org-translate-time (org-element-property :value timestamp))) + (range-end (org-element-property :range-end timestamp))) + (case (org-element-property :type timestamp) + (active (format org-e-latex-active-timestamp-format value)) + (active-range + (concat (format org-e-latex-active-timestamp-format value) + "--" + (format org-e-latex-active-timestamp-format + (org-translate-time range-end)))) + (inactive (format org-e-latex-inactive-timestamp-format value)) + (inactive-range + (concat (format org-e-latex-inactive-timestamp-format value) + "--" + (format org-e-latex-inactive-timestamp-format + (org-translate-time range-end)))) + (otherwise (format org-e-latex-diary-timestamp-format value))))) + + +;;;; Underline + +(defun org-e-latex-underline (underline contents info) + "Transcode UNDERLINE from Org to LaTeX. +CONTENTS is the text with underline markup. INFO is a plist +holding contextual information." + (org-e-latex--text-markup contents 'underline)) + + +;;;; Verbatim + +(defun org-e-latex-verbatim (verbatim contents info) + "Transcode a VERBATIM object from Org to LaTeX. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (org-e-latex--text-markup (org-element-property :value verbatim) 'verbatim)) + + +;;;; Verse Block + +(defun org-e-latex-verse-block (verse-block contents info) + "Transcode a VERSE-BLOCK element from Org to LaTeX. +CONTENTS is verse block contents. INFO is a plist holding +contextual information." + (org-e-latex--wrap-label + verse-block + ;; In a verse environment, add a line break to each newline + ;; character and change each white space at beginning of a line + ;; into a space of 1 em. Also change each blank line with + ;; a vertical space of 1 em. + (progn + (setq contents (replace-regexp-in-string + "^ *\\\\\\\\$" "\\\\vspace*{1em}" + (replace-regexp-in-string + "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" contents))) + (while (string-match "^[ \t]+" contents) + (let ((new-str (format "\\hspace*{%dem}" + (length (match-string 0 contents))))) + (setq contents (replace-match new-str nil t contents)))) + (format "\\begin{verse}\n%s\\end{verse}" contents)))) + + + +;;; Interactive functions + +;;;###autoload +(defun org-e-latex-export-as-latex + (&optional subtreep visible-only body-only ext-plist) + "Export current buffer as a LaTeX buffer. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +Export is done in a buffer named \"*Org E-LATEX Export*\", which +will be displayed when `org-export-show-temporary-export-buffer' +is non-nil." + (interactive) + (let ((outbuf (org-export-to-buffer + 'e-latex "*Org E-LATEX Export*" + subtreep visible-only body-only ext-plist))) + (with-current-buffer outbuf (LaTeX-mode)) + (when org-export-show-temporary-export-buffer + (switch-to-buffer-other-window outbuf)))) + +;;;###autoload +(defun org-e-latex-export-to-latex + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to a LaTeX file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".tex" subtreep pub-dir))) + (org-export-to-file + 'e-latex outfile subtreep visible-only body-only ext-plist))) + +;;;###autoload +(defun org-e-latex-export-to-pdf + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to LaTeX then process through to PDF. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return PDF file's name." + (interactive) + (org-e-latex-compile + (org-e-latex-export-to-latex + subtreep visible-only body-only ext-plist pub-dir))) + +(defun org-e-latex-compile (texfile) + "Compile a TeX file. + +TEXFILE is the name of the file being compiled. Processing is +done through the command specified in `org-e-latex-pdf-process'. + +Return PDF file name or an error if it couldn't be produced." + (let* ((wconfig (current-window-configuration)) + (texfile (file-truename texfile)) + (base (file-name-sans-extension texfile)) + errors) + (message (format "Processing LaTeX file %s ..." texfile)) + (unwind-protect + (progn + (cond + ;; A function is provided: Apply it. + ((functionp org-e-latex-pdf-process) + (funcall org-e-latex-pdf-process (shell-quote-argument texfile))) + ;; A list is provided: Replace %b, %f and %o with appropriate + ;; values in each command before applying it. Output is + ;; redirected to "*Org PDF LaTeX Output*" buffer. + ((consp org-e-latex-pdf-process) + (let* ((out-dir (or (file-name-directory texfile) "./")) + (outbuf (get-buffer-create "*Org PDF LaTeX Output*"))) + (mapc + (lambda (command) + (shell-command + (replace-regexp-in-string + "%b" (shell-quote-argument base) + (replace-regexp-in-string + "%f" (shell-quote-argument texfile) + (replace-regexp-in-string + "%o" (shell-quote-argument out-dir) command t t) t t) t t) + outbuf)) + org-e-latex-pdf-process) + ;; Collect standard errors from output buffer. + (setq errors (org-e-latex--collect-errors outbuf)))) + (t (error "No valid command to process to PDF"))) + (let ((pdffile (concat base ".pdf"))) + ;; Check for process failure. Provide collected errors if + ;; possible. + (if (not (file-exists-p pdffile)) + (error (concat (format "PDF file %s wasn't produced" pdffile) + (when errors (concat ": " errors)))) + ;; Else remove log files, when specified, and signal end of + ;; process to user, along with any error encountered. + (when org-e-latex-remove-logfiles + (dolist (ext org-e-latex-logfiles-extensions) + (let ((file (concat base "." ext))) + (when (file-exists-p file) (delete-file file))))) + (message (concat "Process completed" + (if (not errors) "." + (concat " with errors: " errors))))) + ;; Return output file name. + pdffile)) + (set-window-configuration wconfig)))) + +(defun org-e-latex--collect-errors (buffer) + "Collect some kind of errors from \"pdflatex\" command output. + +BUFFER is the buffer containing output. + +Return collected error types as a string, or nil if there was +none." + (with-current-buffer buffer + (save-excursion + (goto-char (point-max)) + ;; Find final "pdflatex" run. + (when (re-search-backward "^[ \t]*This is pdf.*?TeX.*?Version" nil t) + (let ((case-fold-search t) + (errors "")) + (when (save-excursion + (re-search-forward "Reference.*?undefined" nil t)) + (setq errors (concat errors " [undefined reference]"))) + (when (save-excursion + (re-search-forward "Citation.*?undefined" nil t)) + (setq errors (concat errors " [undefined citation]"))) + (when (save-excursion + (re-search-forward "Undefined control sequence" nil t)) + (setq errors (concat errors " [undefined control sequence]"))) + (when (save-excursion + (re-search-forward "^! LaTeX.*?Error" nil t)) + (setq errors (concat errors " [LaTeX error]"))) + (when (save-excursion + (re-search-forward "^! Package.*?Error" nil t)) + (setq errors (concat errors " [package error]"))) + (and (org-string-nw-p errors) (org-trim errors))))))) + + +(provide 'org-e-latex) +;;; org-e-latex.el ends here diff --git a/contrib/lisp/org-e-man.el b/contrib/lisp/org-e-man.el new file mode 100644 index 0000000..981f831 --- /dev/null +++ b/contrib/lisp/org-e-man.el @@ -0,0 +1,1363 @@ +;; org-e-man.el --- Man Back-End For Org Export Engine + +;; Copyright (C) 2011-2012 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou <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 Man back-end for Org generic exporter. +;; +;; To test it, run +;; +;; M-: (org-export-to-buffer 'e-man "*Test e-Man*") RET +;; +;; in an org-mode buffer then switch to the buffer to see the Man +;; export. See contrib/lisp/org-export.el for more details on how +;; this exporter works. +;; +;; It introduces one new buffer keywords: +;; "MAN_CLASS_OPTIONS". + +;;;; Code: + +(require 'org-export) + +(eval-when-compile (require 'cl)) + +(defvar org-export-man-default-packages-alist) +(defvar org-export-man-packages-alist) + + + + + + +;;;; Define Back-End + +(defvar org-e-man-translate-alist + '((babel-call . org-e-man-babel-call) + (bold . org-e-man-bold) + (center-block . org-e-man-center-block) + (clock . org-e-man-clock) + (code . org-e-man-code) + (comment . org-e-man-comment) + (comment-block . org-e-man-comment-block) + (drawer . org-e-man-drawer) + (dynamic-block . org-e-man-dynamic-block) + (entity . org-e-man-entity) + (example-block . org-e-man-example-block) + (export-block . org-e-man-export-block) + (export-snippet . org-e-man-export-snippet) + (fixed-width . org-e-man-fixed-width) + (footnote-definition . org-e-man-footnote-definition) + (footnote-reference . org-e-man-footnote-reference) + (headline . org-e-man-headline) + (horizontal-rule . org-e-man-horizontal-rule) + (inline-babel-call . org-e-man-inline-babel-call) + (inline-src-block . org-e-man-inline-src-block) + (inlinetask . org-e-man-inlinetask) + (italic . org-e-man-italic) + (item . org-e-man-item) + (keyword . org-e-man-keyword) + (man-environment . org-e-man-man-environment) + (man-fragment . org-e-man-man-fragment) + (line-break . org-e-man-line-break) + (link . org-e-man-link) + (macro . org-e-man-macro) + (paragraph . org-e-man-paragraph) + (plain-list . org-e-man-plain-list) + (plain-text . org-e-man-plain-text) + (planning . org-e-man-planning) + (property-drawer . org-e-man-property-drawer) + (quote-block . org-e-man-quote-block) + (quote-section . org-e-man-quote-section) + (radio-target . org-e-man-radio-target) + (section . org-e-man-section) + (special-block . org-e-man-special-block) + (src-block . org-e-man-src-block) + (statistics-cookie . org-e-man-statistics-cookie) + (strike-through . org-e-man-strike-through) + (subscript . org-e-man-subscript) + (superscript . org-e-man-superscript) + (table . org-e-man-table) + (table-cell . org-e-man-table-cell) + (table-row . org-e-man-table-row) + (target . org-e-man-target) + (template . org-e-man-template) + (timestamp . org-e-man-timestamp) + (underline . org-e-man-underline) + (verbatim . org-e-man-verbatim) + (verse-block . org-e-man-verse-block)) + "Alist between element or object types and translators.") + +(defconst org-e-man-options-alist + '((:date "DATE" nil nil t) + (:man-class "MAN_CLASS" nil nil t) + (:man-class-options "MAN_CLASS_OPTIONS" nil nil t) + (:man-header-extra "MAN_HEADER" nil nil newline)) + "Alist between Man export properties and ways to set them. +See `org-export-options-alist' for more information on the +structure of the values.") + + + + +;;; User Configurable Variables + + +(defgroup org-export-e-man nil + "Options for exporting Org mode files to Man." + :tag "Org Export Man" + :group 'org-export) + + +;;;; Tables + + +(defcustom org-e-man-tables-centered t + "When non-nil, tables are exported in a center environment." + :group 'org-export-e-man + :type 'boolean) + +(defcustom org-e-man-tables-verbatim nil + "When non-nil, tables are exported verbatim." + :group 'org-export-e-man + :type 'boolean) + +(defcustom org-e-man-table-scientific-notation "%sE%s" + "Format string to display numbers in scientific notation. +The format should have \"%s\" twice, for mantissa and exponent +\(i.e. \"%s\\\\times10^{%s}\"). + +When nil, no transformation is made." + :group 'org-export-e-man + :type '(choice + (string :tag "Format string") + (const :tag "No formatting"))) + + +;;;; Inlinetasks + + +;; Src blocks + +(defcustom org-e-man-source-highlight nil + "Use GNU source highlight to embellish source blocks " + :group 'org-export-e-man + :type 'boolean) + +(defcustom org-e-man-source-highlight-langs + '((emacs-lisp "lisp") (lisp "lisp") (clojure "lisp") + (scheme "scheme") + (c "c") (cc "cpp") (csharp "csharp") (d "d") + (fortran "fortran") (cobol "cobol") (pascal "pascal") + (ada "ada") (asm "asm") + (perl "perl") (cperl "perl") + (python "python") (ruby "ruby") (tcl "tcl") (lua "lua") + (java "java") (javascript "javascript") + (tex "latex") + (shell-script "sh") (awk "awk") (diff "diff") (m4 "m4") + (ocaml "caml") (caml "caml") + (sql "sql") (sqlite "sql") + (html "html") (css "css") (xml "xml") + (bat "bat") (bison "bison") (clipper "clipper") + (ldap "ldap") (opa "opa") + (php "php") (postscript "postscript") (prolog "prolog") + (properties "properties") (makefile "makefile") + (tml "tml") (vala "vala") (vbscript "vbscript") (xorg "xorg")) + "Alist mapping languages to their listing language counterpart. +The key is a symbol, the major mode symbol without the \"-mode\". +The value is the string that should be inserted as the language +parameter for the listings package. If the mode name and the +listings name are the same, the language does not need an entry +in this list - but it does not hurt if it is present." + :group 'org-export-e-man + :type '(repeat + (list + (symbol :tag "Major mode ") + (string :tag "Listings language")))) + + +(defvar org-e-man-custom-lang-environments nil + "Alist mapping languages to language-specific Man environments. + +It is used during export of src blocks by the listings and +man packages. For example, + + \(setq org-e-man-custom-lang-environments + '\(\(python \"pythoncode\"\)\)\) + +would have the effect that if org encounters begin_src python +during man export." +) + + +;;;; Plain text + +(defcustom org-e-man-quotes + '(("fr" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "«~") + ("\\(\\S-\\)\"" . "~»") + ("\\(\\s-\\|(\\|^\\)'" . "'")) + ("en" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "``") + ("\\(\\S-\\)\"" . "''") + ("\\(\\s-\\|(\\|^\\)'" . "`"))) + + "Alist for quotes to use when converting english double-quotes. + +The CAR of each item in this alist is the language code. +The CDR of each item in this alist is a list of three CONS: +- the first CONS defines the opening quote; +- the second CONS defines the closing quote; +- the last CONS defines single quotes. + +For each item in a CONS, the first string is a regexp +for allowed characters before/after the quote, the second +string defines the replacement string for this quote." + :group 'org-export-e-man + :type '(list + (cons :tag "Opening quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")) + (cons :tag "Closing quote" + (string :tag "Regexp for char after ") + (string :tag "Replacement quote ")) + (cons :tag "Single quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")))) + + +;;;; Compilation + +(defcustom org-e-man-pdf-process + '("tbl %f | eqn | groff -man | ps2pdf - > %b.pdf" + "tbl %f | eqn | groff -man | ps2pdf - > %b.pdf" + "tbl %f | eqn | groff -man | ps2pdf - > %b.pdf") + + "Commands to process a Man file to a PDF file. +This is a list of strings, each of them will be given to the +shell as a command. %f in the command will be replaced by the +full file name, %b by the file base name \(i.e. without +extension) and %o by the base directory of the file. + + +By default, Org uses 3 runs of to do the processing. + +Alternatively, this may be a Lisp function that does the +processing. This function should accept the file name as +its single argument." + :group 'org-export-pdf + :type '(choice + (repeat :tag "Shell command sequence" + (string :tag "Shell command")) + (const :tag "2 runs of pdfgroff" + ("tbl %f | eqn | groff -mm | ps2pdf - > %b.pdf" + "tbl %f | eqn | groff -mm | ps2pdf - > %b.pdf")) + (const :tag "3 runs of pdfgroff" + ("tbl %f | eqn | groff -mm | ps2pdf - > %b.pdf" + "tbl %f | eqn | groff -mm | ps2pdf - > %b.pdf" + "tbl %f | eqn | groff -mm | ps2pdf - > %b.pdf")) + (function))) + +(defcustom org-e-man-logfiles-extensions + '("log" "out" "toc") + "The list of file extensions to consider as Man logfiles." + :group 'org-export-e-man + :type '(repeat (string :tag "Extension"))) + +(defcustom org-e-man-remove-logfiles t + "Non-nil means remove the logfiles produced by PDF production. +These are the .aux, .log, .out, and .toc files." + :group 'org-export-e-man + :type 'boolean) + + + +;; Preamble + + +;; Adding MAN as a block parser to make sure that its contents +;; does not execute + +(add-to-list 'org-element-block-name-alist + '("MAN" . org-element-export-block-parser)) + + + + + +;;; Internal Functions + +(defun org-e-man--caption/label-string (caption label info) + "Return caption and label Man string for floats. + +CAPTION is a cons cell of secondary strings, the car being the +standard caption and the cdr its short form. LABEL is a string +representing the label. INFO is a plist holding contextual +information. + +If there's no caption nor label, return the empty string. + +For non-floats, see `org-e-man--wrap-label'." + (let ((label-str "")) + (cond + ((and (not caption) (not label)) "") + ((not caption) (format "\\fI%s\\fP" label)) + ;; Option caption format with short name. + ((cdr caption) + (format "\\fR%s\\fP - \\fI%s\\P - %s\n" + (org-export-data (cdr caption) info) + label-str + (org-export-data (car caption) info))) + ;; Standard caption format. + (t (format "\\fR%s\\fP" + (org-export-data (car caption) info)))))) + +(defun org-e-man--quotation-marks (text info) + "Export quotation marks depending on language conventions. +TEXT is a string containing quotation marks to be replaced. INFO +is a plist used as a communication channel." + (mapc (lambda(l) + (let ((start 0)) + (while (setq start (string-match (car l) text start)) + (let ((new-quote (concat (match-string 1 text) (cdr l)))) + (setq text (replace-match new-quote t t text)))))) + (cdr (or (assoc (plist-get info :language) org-e-man-quotes) + ;; Falls back on English. + (assoc "en" org-e-man-quotes)))) + text) + +(defun org-e-man--wrap-label (element output) + "Wrap label associated to ELEMENT around OUTPUT, if appropriate. +This function shouldn't be used for floats. See +`org-e-man--caption/label-string'." + (let ((label (org-element-property :name element))) + (if (or (not output) (not label) (string= output "") (string= label "")) + output + (concat (format "%s\n.br\n" label) output)))) + + + + +;;; Template + +(defun org-e-man-template (contents info) + "Return complete document string after Man conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (let* ((title (org-export-data (plist-get info :title) info)) + (attr + (read (format "(%s)" + (mapconcat + #'identity + (list (plist-get info :man-class-options)) + " ")))) + (section-item (plist-get attr :section-id))) + + (concat + (cond + ((and title (stringp section-item)) + (format ".TH \"%s\" \"%s\" \n" title section-item)) + ((and (string= "" title) (stringp section-item)) + (format ".TH \"%s\" \"%s\" \n" " " section-item)) + (title + (format ".TH \"%s\" \"1\" \n" title)) + (t + ".TH \" \" \"1\" ")) + contents))) + + + + +;;; Transcode Functions + +;;;; Babel Call + +;; Babel Calls are ignored. + + +;;;; Bold + +(defun org-e-man-bold (bold contents info) + "Transcode BOLD from Org to Man. +CONTENTS is the text with bold markup. INFO is a plist holding +contextual information." + (format "\\fB%s\\fP" contents)) + + +;;;; Center Block + +(defun org-e-man-center-block (center-block contents info) + "Transcode a CENTER-BLOCK element from Org to Man. +CONTENTS holds the contents of the center block. INFO is a plist +holding contextual information." + (org-e-man--wrap-label + center-block + (format ".ce %d\n.nf\n%s\n.fi" + (- (length (split-string contents "\n")) 1) + contents))) + + +;;;; Clock + +(defun org-e-man-clock (clock contents info) + "Transcode a CLOCK element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual +information." + "") + + +;;;; Code + +(defun org-e-man-code (code contents info) + "Transcode a CODE object from Org to Man. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "\\fC%s\\fP" code)) + + +;;;; Comment +;; Comments are ignored. + + +;;;; Comment Block +;; Comment Blocks are ignored. + + +;;;; Drawer + +(defun org-e-man-drawer (drawer contents info) + "Transcode a DRAWER element from Org to Man. + DRAWER holds the drawer information + CONTENTS holds the contents of the block. + INFO is a plist holding contextual information. " + contents) + + +;;;; Dynamic Block + +(defun org-e-man-dynamic-block (dynamic-block contents info) + "Transcode a DYNAMIC-BLOCK element from Org to Man. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information. See `org-export-data'." + (org-e-man--wrap-label dynamic-block contents)) + + +;;;; Entity + +(defun org-e-man-entity (entity contents info) + "Transcode an ENTITY object from Org to Man. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + (let ((ent (org-element-property :utf8 entity))) ent)) + + +;;;; Example Block + +(defun org-e-man-example-block (example-block contents info) + "Transcode an EXAMPLE-BLOCK element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual +information." + (org-e-man--wrap-label + example-block + (format ".RS\n.nf\n%s\n.fi\n.RE" + (org-export-format-code-default example-block info)))) + +;;;; Export Block + +(defun org-e-man-export-block (export-block contents info) + "Transcode a EXPORT-BLOCK element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (string= (org-element-property :type export-block) "MAN") + (org-remove-indentation (org-element-property :value export-block)))) + + +;;;; Export Snippet + +(defun org-e-man-export-snippet (export-snippet contents info) + "Transcode a EXPORT-SNIPPET object from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (eq (org-export-snippet-backend export-snippet) 'e-man) + (org-element-property :value export-snippet))) + + +;;;; Fixed Width + +(defun org-e-man-fixed-width (fixed-width contents info) + "Transcode a FIXED-WIDTH element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-man--wrap-label + fixed-width + (format "\\fC\n%s\\fP" + (org-remove-indentation + (org-element-property :value fixed-width))))) + + +;;;; Footnote Definition +;; Footnote Definitions are ignored. + +;;;; Footnote References +;; Footnote References are Ignored + + +;;;; Headline + +(defun org-e-man-headline (headline contents info) + "Transcode an HEADLINE element from Org to Man. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((level (org-export-get-relative-level headline info)) + (numberedp (org-export-numbered-headline-p headline info)) + ;; Section formatting will set two placeholders: one for the + ;; title and the other for the contents. + (section-fmt + (case level + (1 ".SH \"%s\"\n%s") + (2 ".SS \"%s\"\n%s") + (3 ".SS \"%s\"\n%s") + (t nil))) + (text (org-export-data (org-element-property :title headline) info))) + + (cond + ;; Case 1: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + + ;; Case 2. This is a deep sub-tree: export it as a list item. + ;; Also export as items headlines for which no section + ;; format has been found. + ((or (not section-fmt) (org-export-low-level-p headline info)) + ;; Build the real contents of the sub-tree. + (let ((low-level-body + (concat + ;; If the headline is the first sibling, start a list. + (when (org-export-first-sibling-p headline info) + (format "%s\n" ".RS")) + ;; Itemize headline + ".TP\n.ft I\n" text "\n.ft\n" + contents ".RE"))) + ;; If headline is not the last sibling simply return + ;; LOW-LEVEL-BODY. Otherwise, also close the list, before any + ;; blank line. + (if (not (org-export-last-sibling-p headline info)) low-level-body + (replace-regexp-in-string + "[ \t\n]*\\'" "" + low-level-body)))) + + ;; Case 3. Standard headline. Export it as a section. + (t (format section-fmt text contents))))) + + +;;;; Horizontal Rule +;; Not supported + + +;;;; Inline Babel Call +;; Inline Babel Calls are ignored. + + +;;;; Inline Src Block + +(defun org-e-man-inline-src-block (inline-src-block contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to Man. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((code (org-element-property :value inline-src-block))) + (cond + (org-e-man-source-highlight + (let* ((tmpdir (if (featurep 'xemacs) + temp-directory + temporary-file-directory)) + (in-file (make-temp-name + (expand-file-name "srchilite" tmpdir))) + (out-file (make-temp-name + (expand-file-name "reshilite" tmpdir))) + (org-lang (org-element-property :language inline-src-block)) + (lst-lang (cadr (assq (intern org-lang) + org-e-man-source-highlight-langs))) + + (cmd (concat (expand-file-name "source-highlight") + " -s " lst-lang + " -f groff_man" + " -i " in-file + " -o " out-file))) + + (if lst-lang + (let ((code-block "")) + (with-temp-file in-file (insert code)) + (shell-command cmd) + (setq code-block (org-file-contents out-file)) + (delete-file in-file) + (delete-file out-file) + code-block) + (format ".RS\n.nf\n\\fC\\m[black]%s\\m[]\\fP\n.fi\n.RE\n" + code)))) + + ;; Do not use a special package: transcode it verbatim. + (t + (concat ".RS\n.nf\n" "\\fC" "\n" code "\n" + "\\fP\n.fi\n.RE\n"))))) + + +;;;; Inlinetask +;;;; Italic + +(defun org-e-man-italic (italic contents info) + "Transcode ITALIC from Org to Man. +CONTENTS is the text with italic markup. INFO is a plist holding +contextual information." + (format "\\fI%s\\fP" contents)) + + +;;;; Item + +(defun org-e-man-item (item contents info) + + "Transcode an ITEM element from Org to Man. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + + (let* ((bullet (org-element-property :bullet item)) + (type (org-element-property :type (org-element-property :parent item))) + (checkbox (case (org-element-property :checkbox item) + (on "\\o'\\(sq\\(mu'") ;; + (off "\\(sq ") ;; + (trans "\\o'\\(sq\\(mi'"))) ;; + + (tag (let ((tag (org-element-property :tag item))) + ;; Check-boxes must belong to the tag. + (and tag (format "\\fB%s\\fP" + (concat checkbox + (org-export-data tag info))))))) + + (if (and (null tag) + (null checkbox)) + (let* ((bullet (org-trim bullet)) + (marker (cond ((string= "-" bullet) "\\(em") + ((string= "*" bullet) "\\(bu") + ((eq type 'ordered) + (format "%s " (org-trim bullet))) + (t "\\(dg")))) + (concat ".IP " marker " 4\n" + (org-trim (or contents " ")))) + ; else + (concat ".TP\n" (or tag (concat " " checkbox)) "\n" + (org-trim (or contents " ")))))) + + +;;;; Keyword + +(defun org-e-man-keyword (keyword contents info) + "Transcode a KEYWORD element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + (cond + ((string= key "MAN") value) + ((string= key "INDEX") nil) + ;; Invisible targets. + ((string= key "TARGET") nil) + ((string= key "TOC") nil)))) + + +;;;; Man Environment + +(defun org-e-man-man-environment (man-environment contents info) + "Transcode a MAN-ENVIRONMENT element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((label (org-element-property :name man-environment)) + (value (org-remove-indentation + (org-element-property :value man-environment)))) + (if (not (org-string-nw-p label)) value + ;; Environment is labelled: label must be within the environment + ;; (otherwise, a reference pointing to that element will count + ;; the section instead). + (with-temp-buffer + (insert value) + (goto-char (point-min)) + (forward-line) + (insert (format "%s\n" label)) + (buffer-string))))) + + +;;;; Man Fragment + +(defun org-e-man-man-fragment (man-fragment contents info) + "Transcode a MAN-FRAGMENT object from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-element-property :value man-fragment)) + + +;;;; Line Break + +(defun org-e-man-line-break (line-break contents info) + "Transcode a LINE-BREAK object from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + ".br\n") + + +;;;; Link + +(defun org-e-man-link (link desc info) + "Transcode a LINK object from Org to Man. + +DESC is the description part of the link, or the empty string. +INFO is a plist holding contextual information. See +`org-export-data'." + + (let* ((type (org-element-property :type link)) + (raw-path (org-element-property :path link)) + ;; Ensure DESC really exists, or set it to nil. + (desc (and (not (string= desc "")) desc)) + + (path (cond + ((member type '("http" "https" "ftp" "mailto")) + (concat type ":" raw-path)) + ((string= type "file") + (when (string-match "\\(.+\\)::.+" raw-path) + (setq raw-path (match-string 1 raw-path))) + (if (file-name-absolute-p raw-path) + (concat "file://" (expand-file-name raw-path)) + (concat "file://" raw-path))) + (t raw-path))) + protocol) + (cond + ;; External link with a description part. + ((and path desc) (format "%s \\fBat\\fP \\fI%s\\fP" path desc)) + ;; External link without a description part. + (path (format "\\fI%s\\fP" path)) + ;; No path, only description. Try to do something useful. + (t (format "\\fI%s\\fP" desc))))) + + +;;;; Macro + +(defun org-e-man-macro (macro contents info) + "Transcode a MACRO element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + ;; Use available tools. + (org-export-expand-macro macro info)) + + +;;;; Paragraph + +(defun org-e-man-paragraph (paragraph contents info) + "Transcode a PARAGRAPH element from Org to Man. +CONTENTS is the contents of the paragraph, as a string. INFO is +the plist used as a communication channel." + (let ((parent (plist-get (nth 1 paragraph) :parent))) + (when parent + (let ((parent-type (car parent)) + (fixed-paragraph "")) + (cond ((and (eq parent-type 'item) + (plist-get (nth 1 parent) :bullet)) + (setq fixed-paragraph (concat "" contents))) + ((eq parent-type 'section) + (setq fixed-paragraph (concat ".PP\n" contents))) + ((eq parent-type 'footnote-definition) + (setq fixed-paragraph contents)) + (t (setq fixed-paragraph (concat "" contents)))) + fixed-paragraph)))) + + +;;;; Plain List + +(defun org-e-man-plain-list (plain-list contents info) + "Transcode a PLAIN-LIST element from Org to Man. +CONTENTS is the contents of the list. INFO is a plist holding +contextual information." + contents) + + +;;;; Plain Text + +(defun org-e-man-plain-text (text info) + "Transcode a TEXT string from Org to Man. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; Protect + (setq text (replace-regexp-in-string + "\\(?:[^\\]\\|^\\)\\(\\\\\\)\\(?:[^%$#&{}~^_\\]\\|$\\)" + "$\\" text nil t 1)) + + ;; Handle quotation marks + (setq text (org-e-man--quotation-marks text info)) + + ;; Handle break preservation if required. + + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" + text))) + ;; Return value. + text) + + +;;;; Planning + +;;;; Property Drawer + + +;;;; Quote Block + +(defun org-e-man-quote-block (quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to Man. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (org-e-man--wrap-label + quote-block + (format ".RS\n%s\n.RE" contents))) + + +;;;; Quote Section + +(defun org-e-man-quote-section (quote-section contents info) + "Transcode a QUOTE-SECTION element from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((value (org-remove-indentation + (org-element-property :value quote-section)))) + (when value (format ".RS\\fI%s\\fP\n.RE\n" value)))) + + +;;;; Radio Target + +(defun org-e-man-radio-target (radio-target text info) + "Transcode a RADIO-TARGET object from Org to Man. +TEXT is the text of the target. INFO is a plist holding +contextual information." + text) + + +;;;; Section + +(defun org-e-man-section (section contents info) + "Transcode a SECTION element from Org to Man. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + contents) + + +;;;; Special Block + +(defun org-e-man-special-block (special-block contents info) + "Transcode a SPECIAL-BLOCK element from Org to Man. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((type (downcase (org-element-property :type special-block)))) + (org-e-man--wrap-label + special-block + (format "%s\n" contents)))) + + +;;;; Src Block + +(defun org-e-man-src-block (src-block contents info) + "Transcode a SRC-BLOCK element from Org to Man. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + + (let* ((lang (org-element-property :language src-block)) + (caption (org-element-property :caption src-block)) + (label (org-element-property :name src-block)) + (code (org-element-property :value src-block)) + (custom-env (and lang + (cadr (assq (intern lang) + org-e-man-custom-lang-environments)))) + (num-start (case (org-element-property :number-lines src-block) + (continued (org-export-get-loc src-block info)) + (new 0))) + (retain-labels (org-element-property :retain-labels src-block))) + (cond + ;; Case 1. No source fontification. + ((not org-e-man-source-highlight) + (let ((caption-str (org-e-man--caption/label-string caption label info))) + (concat + (format ".RS\n.nf\n\\fC%s\\fP\n.fi\n.RE\n\n" + (org-export-format-code-default src-block info))))) + ((and org-e-man-source-highlight) + (let* ((tmpdir (if (featurep 'xemacs) + temp-directory + temporary-file-directory)) + + (in-file (make-temp-name + (expand-file-name "srchilite" tmpdir))) + (out-file (make-temp-name + (expand-file-name "reshilite" tmpdir))) + + (org-lang (org-element-property :language src-block)) + (lst-lang (cadr (assq (intern org-lang) + org-e-man-source-highlight-langs))) + + (cmd (concat "source-highlight" + " -s " lst-lang + " -f groff_man " + " -i " in-file + " -o " out-file))) + + (if lst-lang + (let ((code-block "")) + (with-temp-file in-file (insert code)) + (shell-command cmd) + (setq code-block (org-file-contents out-file)) + (delete-file in-file) + (delete-file out-file) + code-block) + (format ".RS\n.nf\n\\fC\\m[black]%s\\m[]\\fP\n.fi\n.RE" + code))))))) + + +;;;; Statistics Cookie + +(defun org-e-man-statistics-cookie (statistics-cookie contents info) + "Transcode a STATISTICS-COOKIE object from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-element-property :value statistics-cookie)) + + +;;;; Strike-Through + +(defun org-e-man-strike-through (strike-through contents info) + "Transcode STRIKE-THROUGH from Org to Man. +CONTENTS is the text with strike-through markup. INFO is a plist +holding contextual information." + (format "\\fI%s\\fP" contents)) + + +;;;; Subscript + +(defun org-e-man-subscript (subscript contents info) + "Transcode a SUBSCRIPT object from Org to Man. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "\\d\\s-2%s\\s+2\\u" contents)) + + +;;;; Superscript "^_%s$ + +(defun org-e-man-superscript (superscript contents info) + "Transcode a SUPERSCRIPT object from Org to Man. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "\\u\\s-2%s\\s+2\\d" contents)) + + +;;;; Table +;; +;; `org-e-man-table' is the entry point for table transcoding. It +;; takes care of tables with a "verbatim" attribute. Otherwise, it +;; delegates the job to either `org-e-man-table--table.el-table' or +;; `org-e-man-table--org-table' functions, depending of the type of +;; the table. +;; +;; `org-e-man-table--align-string' is a subroutine used to build +;; alignment string for Org tables. + +(defun org-e-man-table (table contents info) + "Transcode a TABLE element from Org to Man. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (cond + ;; Case 1: verbatim table. + ((or org-e-man-tables-verbatim + (let ((attr + (read + (format + "(%s)" + (mapconcat + #'identity + (org-element-property :attr_man table) + " "))))) + + (and attr (plist-get attr :verbatim)))) + + (format ".nf\n\\fC%s\\fP\n.fi" + ;; Re-create table, without affiliated keywords. + (org-trim + (org-element-interpret-data + `(table nil ,@(org-element-contents table)))))) + ;; Case 2: Standard table. + (t (org-e-man-table--org-table table contents info)))) + +(defun org-e-man-table--align-string (divider table info) + "Return an appropriate Man alignment string. +TABLE is the considered table. INFO is a plist used as +a communication channel." +(let (alignment) + ;; Extract column groups and alignment from first (non-rule) + ;; row. + (org-element-map + (org-element-map + table 'table-row + (lambda (row) + (and (eq (org-element-property :type row) 'standard) row)) + info 'first-match) + 'table-cell + (lambda (cell) + (let* ((borders (org-export-table-cell-borders cell info)) + (raw-width (org-export-table-cell-width cell info)) + (width-cm (when raw-width (/ raw-width 5))) + (width (if raw-width (format "w(%dc)" + (if (< width-cm 1) 1 width-cm)) ""))) + ;; Check left border for the first cell only. + (when (and (memq 'left borders) (not alignment)) + (push "|" alignment)) + (push + (case (org-export-table-cell-alignment cell info) + (left (concat "l" width divider)) + (right (concat "r" width divider)) + (center (concat "c" width divider))) + alignment) + (when (memq 'right borders) (push "|" alignment)))) + info) + (apply 'concat (reverse alignment)))) + +(defun org-e-man-table--org-table (table contents info) + "Return appropriate Man code for an Org table. + +TABLE is the table type element to transcode. CONTENTS is its +contents, as a string. INFO is a plist used as a communication +channel. + +This function assumes TABLE has `org' as its `:type' attribute." + (let* ((label (org-element-property :name table)) + (caption (org-e-man--caption/label-string + (org-element-property :caption table) label info)) + (attr + (read + (format + "(%s)" + (mapconcat + #'identity + (org-element-property :attr_man table) + " ")))) + + (divider (if (plist-get attr :divider) + "|" + " ")) + + ;; Determine alignment string. + (alignment (org-e-man-table--align-string divider table info)) + ;; Extract others display options. + (lines (org-split-string contents "\n")) + + (attr-list + (let ((result-list '())) + (dolist (attr-item + (list + (if (plist-get attr :expand) + "expand" + nil) + + (case (plist-get attr :placement) + ('center "center") + ('left nil) + (t + (if org-e-man-tables-centered + "center" ""))) + + (case (plist-get attr :boxtype) + ('box "box") + ('doublebox "doublebox") + ('allbox "allbox") + ('none nil) + (t "box")))) + + (if attr-item + (add-to-list 'result-list attr-item))) + result-list)) + + + (title-line (plist-get attr :title-line)) + + (table-format + (concat + (format "%s" + (or (car attr-list) "")) + (or + (let ((output-list '())) + (when (cdr attr-list) + (dolist (attr-item (cdr attr-list)) + (setq output-list (concat output-list (format ",%s" attr-item))))) + output-list) + ""))) + + (first-line + (when lines (org-split-string (car lines) "\t")))) + ;; Prepare the final format string for the table. + + (cond + ;; Others. + (lines (concat ".TS\n " table-format ";\n" + + (format "%s.\n" + (let ((final-line "")) + + (when title-line + (dotimes (i (length first-line)) + (setq final-line (concat final-line "cb" divider)))) + + (setq final-line (concat final-line "\n")) + (if alignment + (setq final-line (concat final-line alignment)) + (dotimes (i (length first-line)) + (setq final-line (concat final-line "c" divider)))) + final-line)) + + (format "%s.TE" + (let ((final-line "")) + (dolist (line-item lines) + (cond + (t + (setq lines (org-split-string contents "\n")) + + (setq final-line (concat final-line + (car (org-split-string line-item "\\\\")) "\n"))))) + final-line))))))) + + +;;;; Table Cell + +(defun org-e-man-table-cell (table-cell contents info) + "Transcode a TABLE-CELL element from Org to Man +CONTENTS is the cell contents. INFO is a plist used as +a communication channel." + (concat (if (and contents + org-e-man-table-scientific-notation + (string-match orgtbl-exp-regexp contents)) + ;; Use appropriate format string for scientific + ;; notation. + (format org-e-man-table-scientific-notation + (match-string 1 contents) + (match-string 2 contents)) + contents) + (when (org-export-get-next-element table-cell info) " \t "))) + + +;;;; Table Row + +(defun org-e-man-table-row (table-row contents info) + "Transcode a TABLE-ROW element from Org to Man +CONTENTS is the contents of the row. INFO is a plist used as +a communication channel." + ;; Rules are ignored since table separators are deduced from + ;; borders of the current row. + (when (eq (org-element-property :type table-row) 'standard) + (let* ((attr (mapconcat 'identity + (org-element-property + :attr_man (org-export-get-parent table-row)) + " ")) + ;; TABLE-ROW's borders are extracted from its first cell. + (borders + (org-export-table-cell-borders + (car (org-element-contents table-row)) info))) + (concat + ;; Mark "hline" for horizontal lines. + (cond ((and (memq 'top borders) (memq 'above borders)) "_\n")) + contents "\\\\\n" + (cond + ;; When BOOKTABS are activated enforce bottom rule even when + ;; no hline was specifically marked. + ((and (memq 'bottom borders) (memq 'below borders)) "_\n") + ((memq 'below borders) "_")))))) + + +;;;; Target + +(defun org-e-man-target (target contents info) + "Transcode a TARGET object from Org to Man. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format "\\fI%s\\fP" + (org-export-solidify-link-text (org-element-property :value target)))) + + +;;;; Timestamp + +(defun org-e-man-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to Man. + CONTENTS is nil. INFO is a plist holding contextual + information." + "") + + +;;;; Underline + +(defun org-e-man-underline (underline contents info) + "Transcode UNDERLINE from Org to Man. +CONTENTS is the text with underline markup. INFO is a plist +holding contextual information." + (format "\\fI%s\\fP" contents)) + + +;;;; Verbatim + +(defun org-e-man-verbatim (verbatim contents info) + "Transcode a VERBATIM object from Org to Man. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format ".nf\n%s\n.fi" contents)) + + +;;;; Verse Block + +(defun org-e-man-verse-block (verse-block contents info) + "Transcode a VERSE-BLOCK element from Org to Man. +CONTENTS is verse block contents. INFO is a plist holding +contextual information." + (format ".RS\n.ft I\n%s\n.ft\n.RE" contents)) + + + +;;; Interactive functions + +(defun org-e-man-export-to-man + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to a Man file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only the body +without any markers. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".man" subtreep pub-dir))) + (org-export-to-file + 'e-man outfile subtreep visible-only body-only ext-plist))) + +(defun org-e-man-export-to-pdf + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to Groff then process through to PDF. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write between +markers. + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return PDF file's name." + (interactive) + (org-e-man-compile + (org-e-man-export-to-man + subtreep visible-only body-only ext-plist pub-dir))) + +(defun org-e-man-compile (grofffile) + "Compile a Groff file. + +GROFFFILE is the name of the file being compiled. Processing is +done through the command specified in `org-e-man-pdf-process'. + +Return PDF file name or an error if it couldn't be produced." + (let* ((wconfig (current-window-configuration)) + (grofffile (file-truename grofffile)) + (base (file-name-sans-extension grofffile)) + errors) + (message (format "Processing Groff file %s ..." grofffile)) + (unwind-protect + (progn + (cond + ;; A function is provided: Apply it. + ((functionp org-e-man-pdf-process) + (funcall org-e-man-pdf-process (shell-quote-argument grofffile))) + ;; A list is provided: Replace %b, %f and %o with appropriate + ;; values in each command before applying it. Output is + ;; redirected to "*Org PDF Groff Output*" buffer. + ((consp org-e-man-pdf-process) + (let* ((out-dir (or (file-name-directory grofffile) "./")) + (outbuf (get-buffer-create "*Org PDF Groff Output*"))) + (mapc + (lambda (command) + (shell-command + (replace-regexp-in-string + "%b" (shell-quote-argument base) + (replace-regexp-in-string + "%f" (shell-quote-argument grofffile) + (replace-regexp-in-string + "%o" (shell-quote-argument out-dir) command t t) t t) t t) + outbuf)) + org-e-man-pdf-process) + ;; Collect standard errors from output buffer. + (setq errors (org-e-man-collect-errors outbuf)))) + (t (error "No valid command to process to PDF"))) + (let ((pdffile (concat base ".pdf"))) + ;; Check for process failure. Provide collected errors if + ;; possible. + (if (not (file-exists-p pdffile)) + (error (concat (format "PDF file %s wasn't produced" pdffile) + (when errors (concat ": " errors)))) + ;; Else remove log files, when specified, and signal end of + ;; process to user, along with any error encountered. + (when org-e-man-remove-logfiles + (dolist (ext org-e-man-logfiles-extensions) + (let ((file (concat base "." ext))) + (when (file-exists-p file) (delete-file file))))) + (message (concat "Process completed" + (if (not errors) "." + (concat " with errors: " errors))))) + ;; Return output file name. + pdffile)) + (set-window-configuration wconfig)))) + +(defun org-e-man-collect-errors (buffer) + "Collect some kind of errors from \"groff\" output +BUFFER is the buffer containing output. +Return collected error types as a string, or nil if there was +none." + (with-current-buffer buffer + (save-excursion + (goto-char (point-max)) + ;; Find final run + nil))) + + +(provide 'org-e-man) +;;; org-e-man.el ends here diff --git a/contrib/lisp/org-e-odt.el b/contrib/lisp/org-e-odt.el new file mode 100644 index 0000000..b2f7479 --- /dev/null +++ b/contrib/lisp/org-e-odt.el @@ -0,0 +1,3762 @@ +;;; org-e-odt.el --- OpenDocument Text exporter for Org-mode + +;; Copyright (C) 2010-2012 Free Software Foundation, Inc. + +;; Author: Jambunathan K <kjambunathan at gmail dot com> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(eval-when-compile + (require 'cl) + (require 'table)) +(require 'format-spec) +(require 'org-export) + +;;; Define Back-End + +(org-export-define-backend e-odt + ((bold . org-e-odt-bold) + (center-block . org-e-odt-center-block) + (clock . org-e-odt-clock) + (code . org-e-odt-code) + (drawer . org-e-odt-drawer) + (dynamic-block . org-e-odt-dynamic-block) + (entity . org-e-odt-entity) + (example-block . org-e-odt-example-block) + (export-block . org-e-odt-export-block) + (export-snippet . org-e-odt-export-snippet) + (fixed-width . org-e-odt-fixed-width) + (footnote-definition . org-e-odt-footnote-definition) + (footnote-reference . org-e-odt-footnote-reference) + (headline . org-e-odt-headline) + (horizontal-rule . org-e-odt-horizontal-rule) + (inline-src-block . org-e-odt-inline-src-block) + (inlinetask . org-e-odt-inlinetask) + (italic . org-e-odt-italic) + (item . org-e-odt-item) + (keyword . org-e-odt-keyword) + (latex-environment . org-e-odt-latex-environment) + (latex-fragment . org-e-odt-latex-fragment) + (line-break . org-e-odt-line-break) + (link . org-e-odt-link) + (macro . org-e-odt-macro) + (paragraph . org-e-odt-paragraph) + (plain-list . org-e-odt-plain-list) + (plain-text . org-e-odt-plain-text) + (planning . org-e-odt-planning) + (property-drawer . org-e-odt-property-drawer) + (quote-block . org-e-odt-quote-block) + (quote-section . org-e-odt-quote-section) + (radio-target . org-e-odt-radio-target) + (section . org-e-odt-section) + (special-block . org-e-odt-special-block) + (src-block . org-e-odt-src-block) + (statistics-cookie . org-e-odt-statistics-cookie) + (strike-through . org-e-odt-strike-through) + (subscript . org-e-odt-subscript) + (superscript . org-e-odt-superscript) + (table . org-e-odt-table) + (table-cell . org-e-odt-table-cell) + (table-row . org-e-odt-table-row) + (target . org-e-odt-target) + (template . org-e-odt-template) + (timestamp . org-e-odt-timestamp) + (underline . org-e-odt-underline) + (verbatim . org-e-odt-verbatim) + (verse-block . org-e-odt-verse-block)) + :export-block "ODT" + :options-alist + ((:odt-styles-file "ODT_STYLES_FILE" nil nil t) + (:LaTeX-fragments nil "LaTeX" org-export-with-LaTeX-fragments))) + + +;;; Dependencies + +;;; Hooks + +;;; Function Declarations + +(declare-function org-id-find-id-file "org-id" (id)) +(declare-function hfy-face-to-style "htmlfontify" (fn)) +(declare-function hfy-face-or-def-to-name "htmlfontify" (fn)) +(declare-function archive-zip-extract "arc-mode.el" (archive name)) +(declare-function org-create-math-formula "org" (latex-frag &optional mathml-file)) +(declare-function browse-url-file-url "browse-url" (file)) + + + + +;;; Internal Variables + +(defconst org-e-odt-lib-dir + (file-name-directory load-file-name) + "Location of ODT exporter. +Use this to infer values of `org-e-odt-styles-dir' and +`org-e-odt-schema-dir'.") + +(defvar org-e-odt-data-dir + (expand-file-name "../../etc/" org-e-odt-lib-dir) + "Data directory for ODT exporter. +Use this to infer values of `org-e-odt-styles-dir' and +`org-e-odt-schema-dir'.") + +(defconst org-e-odt-special-string-regexps + '(("\\\\-" . "­\\1") ; shy + ("---\\([^-]\\)" . "—\\1") ; mdash + ("--\\([^-]\\)" . "–\\1") ; ndash + ("\\.\\.\\." . "…")) ; hellip + "Regular expressions for special string conversion.") + +(defconst org-e-odt-schema-dir-list + (list + (and org-e-odt-data-dir + (expand-file-name "./schema/" org-e-odt-data-dir)) ; bail out + (eval-when-compile + (and (boundp 'org-e-odt-data-dir) org-e-odt-data-dir ; see make install + (expand-file-name "./schema/" org-e-odt-data-dir)))) + "List of directories to search for OpenDocument schema files. +Use this list to set the default value of +`org-e-odt-schema-dir'. The entries in this list are +populated heuristically based on the values of `org-e-odt-lib-dir' +and `org-e-odt-data-dir'.") + +(defconst org-e-odt-styles-dir-list + (list + (and org-e-odt-data-dir + (expand-file-name "./styles/" org-e-odt-data-dir)) ; bail out + (eval-when-compile + (and (boundp 'org-e-odt-data-dir) org-e-odt-data-dir ; see make install + (expand-file-name "./styles/" org-e-odt-data-dir))) + (expand-file-name "../../etc/styles/" org-e-odt-lib-dir) ; git + (expand-file-name "./etc/styles/" org-e-odt-lib-dir) ; elpa + (expand-file-name "./org/" data-directory) ; system + ) + "List of directories to search for OpenDocument styles files. +See `org-e-odt-styles-dir'. The entries in this list are populated +heuristically based on the values of `org-e-odt-lib-dir' and +`org-e-odt-data-dir'.") + +(defconst org-e-odt-styles-dir + (let* ((styles-dir + (catch 'styles-dir + (message "Debug (org-e-odt): Searching for OpenDocument styles files...") + (mapc (lambda (styles-dir) + (when styles-dir + (message "Debug (org-e-odt): Trying %s..." styles-dir) + (when (and (file-readable-p + (expand-file-name + "OrgOdtContentTemplate.xml" styles-dir)) + (file-readable-p + (expand-file-name + "OrgOdtStyles.xml" styles-dir))) + (message "Debug (org-e-odt): Using styles under %s" + styles-dir) + (throw 'styles-dir styles-dir)))) + org-e-odt-styles-dir-list) + nil))) + (unless styles-dir + (error "Error (org-e-odt): Cannot find factory styles files, aborting")) + styles-dir) + "Directory that holds auxiliary XML files used by the ODT exporter. + +This directory contains the following XML files - + \"OrgOdtStyles.xml\" and \"OrgOdtContentTemplate.xml\". These + XML files are used as the default values of + `org-e-odt-styles-file' and + `org-e-odt-content-template-file'. + +The default value of this variable varies depending on the +version of org in use and is initialized from +`org-e-odt-styles-dir-list'. Note that the user could be using org +from one of: org's own private git repository, GNU ELPA tar or +standard Emacs.") + +(defconst org-e-odt-bookmark-prefix "OrgXref.") + +(defconst org-e-odt-manifest-file-entry-tag + "\n<manifest:file-entry manifest:media-type=\"%s\" manifest:full-path=\"%s\"%s/>") + +(defconst org-e-odt-file-extensions + '(("odt" . "OpenDocument Text") + ("ott" . "OpenDocument Text Template") + ("odm" . "OpenDocument Master Document") + ("ods" . "OpenDocument Spreadsheet") + ("ots" . "OpenDocument Spreadsheet Template") + ("odg" . "OpenDocument Drawing (Graphics)") + ("otg" . "OpenDocument Drawing Template") + ("odp" . "OpenDocument Presentation") + ("otp" . "OpenDocument Presentation Template") + ("odi" . "OpenDocument Image") + ("odf" . "OpenDocument Formula") + ("odc" . "OpenDocument Chart"))) + +(defvar org-e-odt-table-style-format + " +<style:style style:name=\"%s\" style:family=\"table\"> + <style:table-properties style:rel-width=\"%d%%\" fo:margin-top=\"0cm\" fo:margin-bottom=\"0.20cm\" table:align=\"center\"/> +</style:style> +" + "Template for auto-generated Table styles.") + +(defvar org-e-odt-automatic-styles '() + "Registry of automatic styles for various OBJECT-TYPEs. +The variable has the following form: +\(\(OBJECT-TYPE-A + \(\(OBJECT-NAME-A.1 OBJECT-PROPS-A.1\) + \(OBJECT-NAME-A.2 OBJECT-PROPS-A.2\) ...\)\) + \(OBJECT-TYPE-B + \(\(OBJECT-NAME-B.1 OBJECT-PROPS-B.1\) + \(OBJECT-NAME-B.2 OBJECT-PROPS-B.2\) ...\)\) + ...\). + +OBJECT-TYPEs could be \"Section\", \"Table\", \"Figure\" etc. +OBJECT-PROPS is (typically) a plist created by passing +\"#+ATTR_ODT: \" option to `org-e-odt-parse-block-attributes'. + +Use `org-e-odt-add-automatic-style' to add update this variable.'") + +(defvar org-e-odt-object-counters nil + "Running counters for various OBJECT-TYPEs. +Use this to generate automatic names and style-names. See +`org-e-odt-add-automatic-style'.") + +(defvar org-e-odt-src-block-paragraph-format + "<style:style style:name=\"OrgSrcBlock\" style:family=\"paragraph\" style:parent-style-name=\"Preformatted_20_Text\"> + <style:paragraph-properties fo:background-color=\"%s\" fo:padding=\"0.049cm\" fo:border=\"0.51pt solid #000000\" style:shadow=\"none\"> + <style:background-image/> + </style:paragraph-properties> + <style:text-properties fo:color=\"%s\"/> + </style:style>" + "Custom paragraph style for colorized source and example blocks. +This style is much the same as that of \"OrgFixedWidthBlock\" +except that the foreground and background colors are set +according to the default face identified by the `htmlfontify'.") + +(defvar hfy-optimisations) +(defvar org-e-odt-embedded-formulas-count 0) +(defvar org-e-odt-entity-frame-styles + '(("As-CharImage" "__Figure__" ("OrgInlineImage" nil "as-char")) + ("ParagraphImage" "__Figure__" ("OrgDisplayImage" nil "paragraph")) + ("PageImage" "__Figure__" ("OrgPageImage" nil "page")) + ("CaptionedAs-CharImage" "__Figure__" + ("OrgCaptionedImage" + " style:rel-width=\"100%\" style:rel-height=\"scale\"" "paragraph") + ("OrgInlineImage" nil "as-char")) + ("CaptionedParagraphImage" "__Figure__" + ("OrgCaptionedImage" + " style:rel-width=\"100%\" style:rel-height=\"scale\"" "paragraph") + ("OrgImageCaptionFrame" nil "paragraph")) + ("CaptionedPageImage" "__Figure__" + ("OrgCaptionedImage" + " style:rel-width=\"100%\" style:rel-height=\"scale\"" "paragraph") + ("OrgPageImageCaptionFrame" nil "page")) + ("InlineFormula" "__MathFormula__" ("OrgInlineFormula" nil "as-char")) + ("DisplayFormula" "__MathFormula__" ("OrgDisplayFormula" nil "as-char")) + ("CaptionedDisplayFormula" "__MathFormula__" + ("OrgCaptionedFormula" nil "paragraph") + ("OrgFormulaCaptionFrame" nil "as-char")))) + +(defvar org-e-odt-embedded-images-count 0) +(defvar org-e-odt-image-size-probe-method + (append (and (executable-find "identify") '(imagemagick)) ; See Bug#10675 + '(emacs fixed)) + "Ordered list of methods for determining image sizes.") + +(defvar org-e-odt-default-image-sizes-alist + '(("as-char" . (5 . 0.4)) + ("paragraph" . (5 . 5))) + "Hardcoded image dimensions one for each of the anchor + methods.") + +;; A4 page size is 21.0 by 29.7 cms +;; The default page settings has 2cm margin on each of the sides. So +;; the effective text area is 17.0 by 25.7 cm +(defvar org-e-odt-max-image-size '(17.0 . 20.0) + "Limiting dimensions for an embedded image.") + +(defvar org-e-odt-label-styles + '(("math-formula" "%c" "text" "(%n)") + ("math-label" "(%n)" "text" "(%n)") + ("category-and-value" "%e %n: %c" "category-and-value" "%e %n") + ("value" "%e %n: %c" "value" "%n")) + "Specify how labels are applied and referenced. +This is an alist where each element is of the +form (LABEL-STYLE-NAME LABEL-ATTACH-FMT LABEL-REF-MODE +LABEL-REF-FMT). + +LABEL-ATTACH-FMT controls how labels and captions are attached to +an entity. It may contain following specifiers - %e, %n and %c. +%e is replaced with the CATEGORY-NAME. %n is replaced with +\"<text:sequence ...> SEQNO </text:sequence>\". %c is replaced +with CAPTION. See `org-e-odt-format-label-definition'. + +LABEL-REF-MODE and LABEL-REF-FMT controls how label references +are generated. The following XML is generated for a label +reference - \"<text:sequence-ref +text:reference-format=\"LABEL-REF-MODE\" ...> LABEL-REF-FMT +</text:sequence-ref>\". LABEL-REF-FMT may contain following +specifiers - %e and %n. %e is replaced with the CATEGORY-NAME. +%n is replaced with SEQNO. See +`org-e-odt-format-label-reference'.") + +(defvar org-e-odt-category-map-alist + '(("__Table__" "Table" "value" "Table") + ("__Figure__" "Illustration" "value" "Figure") + ("__MathFormula__" "Text" "math-formula" "Equation") + ("__DvipngImage__" "Equation" "value" "Equation") + ("__Listing__" "Listing" "value" "Listing") + ;; ("__Table__" "Table" "category-and-value") + ;; ("__Figure__" "Figure" "category-and-value") + ;; ("__DvipngImage__" "Equation" "category-and-value") + ) + "Map a CATEGORY-HANDLE to OD-VARIABLE and LABEL-STYLE. +This is a list where each entry is of the form \\(CATEGORY-HANDLE +OD-VARIABLE LABEL-STYLE CATEGORY-NAME\\). CATEGORY_HANDLE +identifies the captionable entity in question. OD-VARIABLE is +the OpenDocument sequence counter associated with the entity. +These counters are declared within +\"<text:sequence-decls>...</text:sequence-decls>\" block of +`org-e-odt-content-template-file'. LABEL-STYLE is a key into +`org-e-odt-label-styles' and specifies how a given entity should +be captioned and referenced. CATEGORY-NAME is used for +qualifying captions on export. You can modify the CATEGORY-NAME +used in the exported document by modifying +`org-export-dictionary'. For example, an embedded image in an +English document is captioned as \"Figure 1: Orgmode Logo\", by +default. If you want the image to be captioned as \"Illustration +1: Orgmode Logo\" instead, install an entry in +`org-export-dictionary' which translates \"Figure\" to +\"Illustration\" when the language is \"en\" and encoding is +`:utf-8'.") + +(defvar org-e-odt-manifest-file-entries nil) +(defvar hfy-user-sheet-assoc) + +(defvar org-e-odt-zip-dir nil + "Temporary work directory for OpenDocument exporter.") + + + +;;; User Configuration Variables + +(defgroup org-export-e-odt nil + "Options for exporting Org mode files to ODT." + :tag "Org Export ODT" + :group 'org-export) + + +;;;; Debugging + +(defcustom org-e-odt-prettify-xml nil + "Specify whether or not the xml output should be prettified. +When this option is turned on, `indent-region' is run on all +component xml buffers before they are saved. Turn this off for +regular use. Turn this on if you need to examine the xml +visually." + :group 'org-export-e-odt + :version "24.1" + :type 'boolean) + + +;;;; Document schema + +(defcustom org-e-odt-schema-dir + (let* ((schema-dir + (catch 'schema-dir + (message "Debug (org-e-odt): Searching for OpenDocument schema files...") + (mapc + (lambda (schema-dir) + (when schema-dir + (message "Debug (org-e-odt): Trying %s..." schema-dir) + (when (and (file-readable-p + (expand-file-name "od-manifest-schema-v1.2-cs01.rnc" + schema-dir)) + (file-readable-p + (expand-file-name "od-schema-v1.2-cs01.rnc" + schema-dir)) + (file-readable-p + (expand-file-name "schemas.xml" schema-dir))) + (message "Debug (org-e-odt): Using schema files under %s" + schema-dir) + (throw 'schema-dir schema-dir)))) + org-e-odt-schema-dir-list) + (message "Debug (org-e-odt): No OpenDocument schema files installed") + nil))) + schema-dir) + "Directory that contains OpenDocument schema files. + +This directory contains: +1. rnc files for OpenDocument schema +2. a \"schemas.xml\" file that specifies locating rules needed + for auto validation of OpenDocument XML files. + +Use the customize interface to set this variable. This ensures +that `rng-schema-locating-files' is updated and auto-validation +of OpenDocument XML takes place based on the value +`rng-nxml-auto-validate-flag'. + +The default value of this variable varies depending on the +version of org in use and is initialized from +`org-e-odt-schema-dir-list'. The OASIS schema files are available +only in the org's private git repository. It is *not* bundled +with GNU ELPA tar or standard Emacs distribution." + :type '(choice + (const :tag "Not set" nil) + (directory :tag "Schema directory")) + :group 'org-export-e-odt + :version "24.1" + :set + (lambda (var value) + "Set `org-e-odt-schema-dir'. +Also add it to `rng-schema-locating-files'." + (let ((schema-dir value)) + (set var + (if (and + (file-readable-p + (expand-file-name "od-manifest-schema-v1.2-cs01.rnc" schema-dir)) + (file-readable-p + (expand-file-name "od-schema-v1.2-cs01.rnc" schema-dir)) + (file-readable-p + (expand-file-name "schemas.xml" schema-dir))) + schema-dir + (when value + (message "Error (org-e-odt): %s has no OpenDocument schema files" + value)) + nil))) + (when org-e-odt-schema-dir + (eval-after-load 'rng-loc + '(add-to-list 'rng-schema-locating-files + (expand-file-name "schemas.xml" + org-e-odt-schema-dir)))))) + + +;;;; Document styles + +(defcustom org-e-odt-content-template-file nil + "Template file for \"content.xml\". +The exporter embeds the exported content just before +\"</office:text>\" element. + +If unspecified, the file named \"OrgOdtContentTemplate.xml\" +under `org-e-odt-styles-dir' is used." + :type 'file + :group 'org-export-e-odt + :version "24.1") + +(defcustom org-e-odt-styles-file nil + "Default styles file for use with ODT export. +Valid values are one of: +1. nil +2. path to a styles.xml file +3. path to a *.odt or a *.ott file +4. list of the form (ODT-OR-OTT-FILE (FILE-MEMBER-1 FILE-MEMBER-2 +...)) + +In case of option 1, an in-built styles.xml is used. See +`org-e-odt-styles-dir' for more information. + +In case of option 3, the specified file is unzipped and the +styles.xml embedded therein is used. + +In case of option 4, the specified ODT-OR-OTT-FILE is unzipped +and FILE-MEMBER-1, FILE-MEMBER-2 etc are copied in to the +generated odt file. Use relative path for specifying the +FILE-MEMBERS. styles.xml must be specified as one of the +FILE-MEMBERS. + +Use options 1, 2 or 3 only if styles.xml alone suffices for +achieving the desired formatting. Use option 4, if the styles.xml +references additional files like header and footer images for +achieving the desired formatting. + +Use \"#+ODT_STYLES_FILE: ...\" directive to set this variable on +a per-file basis. For example, + +#+ODT_STYLES_FILE: \"/path/to/styles.xml\" or +#+ODT_STYLES_FILE: (\"/path/to/file.ott\" (\"styles.xml\" \"image/hdr.png\"))." + :group 'org-export-e-odt + :version "24.1" + :type + '(choice + (const :tag "Factory settings" nil) + (file :must-match t :tag "styles.xml") + (file :must-match t :tag "ODT or OTT file") + (list :tag "ODT or OTT file + Members" + (file :must-match t :tag "ODF Text or Text Template file") + (cons :tag "Members" + (file :tag " Member" "styles.xml") + (repeat (file :tag "Member")))))) + +(defcustom org-e-odt-display-outline-level 2 + "Outline levels considered for enumerating captioned entities." + :group 'org-export-e-odt + :version "24.2" + :type 'integer) + +;;;; Document conversion + +(defcustom org-e-odt-convert-processes + '(("LibreOffice" + "soffice --headless --convert-to %f%x --outdir %d %i") + ("unoconv" + "unoconv -f %f -o %d %i")) + "Specify a list of document converters and their usage. +The converters in this list are offered as choices while +customizing `org-e-odt-convert-process'. + +This variable is a list where each element is of the +form (CONVERTER-NAME CONVERTER-CMD). CONVERTER-NAME is the name +of the converter. CONVERTER-CMD is the shell command for the +converter and can contain format specifiers. These format +specifiers are interpreted as below: + +%i input file name in full +%I input file name as a URL +%f format of the output file +%o output file name in full +%O output file name as a URL +%d output dir in full +%D output dir as a URL. +%x extra options as set in `org-e-odt-convert-capabilities'." + :group 'org-export-e-odt + :version "24.1" + :type + '(choice + (const :tag "None" nil) + (alist :tag "Converters" + :key-type (string :tag "Converter Name") + :value-type (group (string :tag "Command line"))))) + +(defcustom org-e-odt-convert-process "LibreOffice" + "Use this converter to convert from \"odt\" format to other formats. +During customization, the list of converter names are populated +from `org-e-odt-convert-processes'." + :group 'org-export-e-odt + :version "24.1" + :type '(choice :convert-widget + (lambda (w) + (apply 'widget-convert (widget-type w) + (eval (car (widget-get w :args))))) + `((const :tag "None" nil) + ,@(mapcar (lambda (c) + `(const :tag ,(car c) ,(car c))) + org-e-odt-convert-processes)))) + +(defcustom org-e-odt-convert-capabilities + '(("Text" + ("odt" "ott" "doc" "rtf" "docx") + (("pdf" "pdf") ("odt" "odt") ("rtf" "rtf") ("ott" "ott") + ("doc" "doc" ":\"MS Word 97\"") ("docx" "docx") ("html" "html"))) + ("Web" + ("html") + (("pdf" "pdf") ("odt" "odt") ("html" "html"))) + ("Spreadsheet" + ("ods" "ots" "xls" "csv" "xlsx") + (("pdf" "pdf") ("ots" "ots") ("html" "html") ("csv" "csv") ("ods" "ods") + ("xls" "xls") ("xlsx" "xlsx"))) + ("Presentation" + ("odp" "otp" "ppt" "pptx") + (("pdf" "pdf") ("swf" "swf") ("odp" "odp") ("otp" "otp") ("ppt" "ppt") + ("pptx" "pptx") ("odg" "odg")))) + "Specify input and output formats of `org-e-odt-convert-process'. +More correctly, specify the set of input and output formats that +the user is actually interested in. + +This variable is an alist where each element is of the +form (DOCUMENT-CLASS INPUT-FMT-LIST OUTPUT-FMT-ALIST). +INPUT-FMT-LIST is a list of INPUT-FMTs. OUTPUT-FMT-ALIST is an +alist where each element is of the form (OUTPUT-FMT +OUTPUT-FILE-EXTENSION EXTRA-OPTIONS). + +The variable is interpreted as follows: +`org-e-odt-convert-process' can take any document that is in +INPUT-FMT-LIST and produce any document that is in the +OUTPUT-FMT-LIST. A document converted to OUTPUT-FMT will have +OUTPUT-FILE-EXTENSION as the file name extension. OUTPUT-FMT +serves dual purposes: +- It is used for populating completion candidates during + `org-e-odt-convert' commands. +- It is used as the value of \"%f\" specifier in + `org-e-odt-convert-process'. + +EXTRA-OPTIONS is used as the value of \"%x\" specifier in +`org-e-odt-convert-process'. + +DOCUMENT-CLASS is used to group a set of file formats in +INPUT-FMT-LIST in to a single class. + +Note that this variable inherently captures how LibreOffice based +converters work. LibreOffice maps documents of various formats +to classes like Text, Web, Spreadsheet, Presentation etc and +allow document of a given class (irrespective of it's source +format) to be converted to any of the export formats associated +with that class. + +See default setting of this variable for an typical +configuration." + :group 'org-export-e-odt + :version "24.1" + :type + '(choice + (const :tag "None" nil) + (alist :tag "Capabilities" + :key-type (string :tag "Document Class") + :value-type + (group (repeat :tag "Input formats" (string :tag "Input format")) + (alist :tag "Output formats" + :key-type (string :tag "Output format") + :value-type + (group (string :tag "Output file extension") + (choice + (const :tag "None" nil) + (string :tag "Extra options")))))))) + +(defcustom org-e-odt-preferred-output-format nil + "Automatically post-process to this format after exporting to \"odt\". +Interactive commands `org-export-as-e-odt' and +`org-export-as-e-odt-and-open' export first to \"odt\" format and +then use `org-e-odt-convert-process' to convert the +resulting document to this format. During customization of this +variable, the list of valid values are populated based on +`org-e-odt-convert-capabilities'." + :group 'org-export-e-odt + :version "24.1" + :type '(choice :convert-widget + (lambda (w) + (apply 'widget-convert (widget-type w) + (eval (car (widget-get w :args))))) + `((const :tag "None" nil) + ,@(mapcar (lambda (c) + `(const :tag ,c ,c)) + (org-e-odt-reachable-formats "odt"))))) + + +;;;; Drawers + +(defcustom org-e-odt-format-drawer-function nil + "Function called to format a drawer in HTML code. + +The function must accept two parameters: + NAME the drawer name, like \"LOGBOOK\" + CONTENTS the contents of the drawer. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-odt-format-drawer-default \(name contents\) + \"Format a drawer element for HTML export.\" + contents\)" + :group 'org-export-e-odt + :type 'function) + + +;;;; Headline + +(defcustom org-e-odt-format-headline-function nil + "Function to format headline text. + +This function will be called with 5 arguments: +TODO the todo keyword \(string or nil\). +TODO-TYPE the type of todo \(symbol: `todo', `done', nil\) +PRIORITY the priority of the headline \(integer or nil\) +TEXT the main headline text \(string\). +TAGS the tags string, separated with colons \(string or nil\). + +The function result will be used in the section format string. + +As an example, one could set the variable to the following, in +order to reproduce the default set-up: + +\(defun org-e-odt-format-headline \(todo todo-type priority text tags\) + \"Default format function for an headline.\" + \(concat \(when todo + \(format \"\\\\textbf{\\\\textsc{\\\\textsf{%s}}} \" todo\)\) + \(when priority + \(format \"\\\\framebox{\\\\#%c} \" priority\)\) + text + \(when tags \(format \"\\\\hfill{}\\\\textsc{%s}\" tags\)\)\)\)" + :group 'org-export-e-odt + :type 'function) + + +;;;; Inlinetasks + +(defcustom org-e-odt-format-inlinetask-function nil + "Function called to format an inlinetask in HTML code. + +The function must accept six parameters: + TODO the todo keyword, as a string + TODO-TYPE the todo type, a symbol among `todo', `done' and nil. + PRIORITY the inlinetask priority, as a string + NAME the inlinetask name, as a string. + TAGS the inlinetask tags, as a string. + CONTENTS the contents of the inlinetask, as a string. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-odt-format-inlinetask \(todo type priority name tags contents\) +\"Format an inline task element for HTML export.\" + \(let \(\(full-title + \(concat + \(when todo + \(format \"\\\\textbf{\\\\textsf{\\\\textsc{%s}}} \" todo\)\) + \(when priority \(format \"\\\\framebox{\\\\#%c} \" priority\)\) + title + \(when tags \(format \"\\\\hfill{}\\\\textsc{%s}\" tags\)\)\)\)\) + \(format \(concat \"\\\\begin{center}\\n\" + \"\\\\fbox{\\n\" + \"\\\\begin{minipage}[c]{.6\\\\textwidth}\\n\" + \"%s\\n\\n\" + \"\\\\rule[.8em]{\\\\textwidth}{2pt}\\n\\n\" + \"%s\" + \"\\\\end{minipage}}\" + \"\\\\end{center}\"\) + full-title contents\)\)" + :group 'org-export-e-odt + :type 'function) + + +;;;; Links + +(defcustom org-e-odt-inline-image-rules + '(("file" . "\\.\\(jpeg\\|jpg\\|png\\|gif\\)\\'")) + "Rules characterizing image files that can be inlined into HTML. + +A rule consists in an association whose key is the type of link +to consider, and value is a regexp that will be matched against +link's path. + +Note that, by default, the image extension *actually* allowed +depend on the way the HTML file is processed. When used with +pdflatex, pdf, jpg and png images are OK. When processing +through dvi to Postscript, only ps and eps are allowed. The +default we use here encompasses both." + :group 'org-export-e-odt + :type '(alist :key-type (string :tag "Type") + :value-type (regexp :tag "Path"))) + +(defcustom org-e-odt-pixels-per-inch display-pixels-per-inch + "Scaling factor for converting images pixels to inches. +Use this for sizing of embedded images. See Info node `(org) +Images in ODT export' for more information." + :type 'float + :group 'org-export-e-odt + :version "24.1") + + +;;;; Plain text + +(defcustom org-e-odt-quotes + '(("fr" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "« ") + ("\\(\\S-\\)\"" . "» ") + ("\\(\\s-\\|(\\|^\\)'" . "'")) + ("en" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "“") + ("\\(\\S-\\)\"" . "”") + ("\\(\\s-\\|(\\|^\\)'" . "‘") + ("\\(\\S-\\)'" . "’"))) + "Alist for quotes to use when converting english double-quotes. + +The CAR of each item in this alist is the language code. +The CDR of each item in this alist is a list of three CONS: +- the first CONS defines the opening quote; +- the second CONS defines the closing quote; +- the last CONS defines single quotes. + +For each item in a CONS, the first string is a regexp +for allowed characters before/after the quote, the second +string defines the replacement string for this quote." + :group 'org-export-e-odt + :type '(list + (cons :tag "Opening quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")) + (cons :tag "Closing quote" + (string :tag "Regexp for char after ") + (string :tag "Replacement quote ")) + (cons :tag "Single quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")))) + + +;;;; Src Block + +(defcustom org-e-odt-create-custom-styles-for-srcblocks t + "Whether custom styles for colorized source blocks be automatically created. +When this option is turned on, the exporter creates custom styles +for source blocks based on the advice of `htmlfontify'. Creation +of custom styles happen as part of `org-e-odt-hfy-face-to-css'. + +When this option is turned off exporter does not create such +styles. + +Use the latter option if you do not want the custom styles to be +based on your current display settings. It is necessary that the +styles.xml already contains needed styles for colorizing to work. + +This variable is effective only if +`org-e-odt-fontify-srcblocks' is turned on." + :group 'org-export-e-odt + :version "24.1" + :type 'boolean) + +(defcustom org-e-odt-fontify-srcblocks t + "Specify whether or not source blocks need to be fontified. +Turn this option on if you want to colorize the source code +blocks in the exported file. For colorization to work, you need +to make available an enhanced version of `htmlfontify' library." + :type 'boolean + :group 'org-export-e-odt + :version "24.1") + + +;;;; Table + +(defcustom org-e-odt-table-caption-above t + "When non-nil, place caption string at the beginning of the table. +Otherwise, place it near the end." + :group 'org-export-e-odt + :type 'boolean) + +(defcustom org-e-odt-table-styles + '(("OrgEquation" "OrgEquation" + ((use-first-column-styles . t) + (use-last-column-styles . t)))) + "Specify how Table Styles should be derived from a Table Template. +This is a list where each element is of the +form (TABLE-STYLE-NAME TABLE-TEMPLATE-NAME TABLE-CELL-OPTIONS). + +TABLE-STYLE-NAME is the style associated with the table through +\"#+ATTR_ODT: :style TABLE-STYLE-NAME\" line. + +TABLE-TEMPLATE-NAME is a set of - upto 9 - automatic +TABLE-CELL-STYLE-NAMEs and PARAGRAPH-STYLE-NAMEs (as defined +below) that is included in +`org-e-odt-content-template-file'. + +TABLE-CELL-STYLE-NAME := TABLE-TEMPLATE-NAME + TABLE-CELL-TYPE + + \"TableCell\" +PARAGRAPH-STYLE-NAME := TABLE-TEMPLATE-NAME + TABLE-CELL-TYPE + + \"TableParagraph\" +TABLE-CELL-TYPE := \"FirstRow\" | \"LastColumn\" | + \"FirstRow\" | \"LastRow\" | + \"EvenRow\" | \"OddRow\" | + \"EvenColumn\" | \"OddColumn\" | \"\" +where \"+\" above denotes string concatenation. + +TABLE-CELL-OPTIONS is an alist where each element is of the +form (TABLE-CELL-STYLE-SELECTOR . ON-OR-OFF). +TABLE-CELL-STYLE-SELECTOR := `use-first-row-styles' | + `use-last-row-styles' | + `use-first-column-styles' | + `use-last-column-styles' | + `use-banding-rows-styles' | + `use-banding-columns-styles' | + `use-first-row-styles' +ON-OR-OFF := `t' | `nil' + +For example, with the following configuration + +\(setq org-e-odt-table-styles + '\(\(\"TableWithHeaderRowsAndColumns\" \"Custom\" + \(\(use-first-row-styles . t\) + \(use-first-column-styles . t\)\)\) + \(\"TableWithHeaderColumns\" \"Custom\" + \(\(use-first-column-styles . t\)\)\)\)\) + +1. A table associated with \"TableWithHeaderRowsAndColumns\" + style will use the following table-cell styles - + \"CustomFirstRowTableCell\", \"CustomFirstColumnTableCell\", + \"CustomTableCell\" and the following paragraph styles + \"CustomFirstRowTableParagraph\", + \"CustomFirstColumnTableParagraph\", \"CustomTableParagraph\" + as appropriate. + +2. A table associated with \"TableWithHeaderColumns\" style will + use the following table-cell styles - + \"CustomFirstColumnTableCell\", \"CustomTableCell\" and the + following paragraph styles + \"CustomFirstColumnTableParagraph\", \"CustomTableParagraph\" + as appropriate.. + +Note that TABLE-TEMPLATE-NAME corresponds to the +\"<table:table-template>\" elements contained within +\"<office:styles>\". The entries (TABLE-STYLE-NAME +TABLE-TEMPLATE-NAME TABLE-CELL-OPTIONS) correspond to +\"table:template-name\" and \"table:use-first-row-styles\" etc +attributes of \"<table:table>\" element. Refer ODF-1.2 +specification for more information. Also consult the +implementation filed under `org-e-odt-get-table-cell-styles'. + +The TABLE-STYLE-NAME \"OrgEquation\" is used internally for +formatting of numbered display equations. Do not delete this +style from the list." + :group 'org-export-e-odt + :version "24.1" + :type '(choice + (const :tag "None" nil) + (repeat :tag "Table Styles" + (list :tag "Table Style Specification" + (string :tag "Table Style Name") + (string :tag "Table Template Name") + (alist :options (use-first-row-styles + use-last-row-styles + use-first-column-styles + use-last-column-styles + use-banding-rows-styles + use-banding-columns-styles) + :key-type symbol + :value-type (const :tag "True" t)))))) + + + +;;; Internal functions + +;;;; Date + +(defun org-e-odt--date (&optional org-ts fmt) + (save-match-data + (let* ((time + (and (stringp org-ts) + (string-match org-ts-regexp0 org-ts) + (apply 'encode-time + (org-fix-decoded-time + (org-parse-time-string (match-string 0 org-ts) t))))) + date) + (cond + (fmt (format-time-string fmt time)) + (t (setq date (format-time-string "%Y-%m-%dT%H:%M:%S%z" time)) + (format "%s:%s" (substring date 0 -2) (substring date -2))))))) + +;;;; Frame + +(defun org-e-odt--frame (text width height style &optional extra + anchor-type) + (let ((frame-attrs + (concat + (if width (format " svg:width=\"%0.2fcm\"" width) "") + (if height (format " svg:height=\"%0.2fcm\"" height) "") + extra + (format " text:anchor-type=\"%s\"" (or anchor-type "paragraph"))))) + (format + "\n<draw:frame draw:style-name=\"%s\"%s>\n%s\n</draw:frame>" + style frame-attrs + (concat text + (let ((title (get-text-property 0 :title text)) + (desc (get-text-property 0 :description text))) + (concat (and title + (format "<svg:title>%s</svg:title>" + (org-e-odt-encode-plain-text title t))) + (and desc + (format "<svg:desc>%s</svg:desc>" + (org-e-odt-encode-plain-text desc t))))))))) + +;;;; Library wrappers + +(defun org-e-odt--adopt-elements (parent &rest children) + (prog1 parent + (mapc (lambda (child) + (let ((parent-1 (org-element-adopt-element parent child nil))) + (assert (eq parent-1 parent)))) + children))) + +(defun org-e-odt--zip-extract (archive members target) + (when (atom members) (setq members (list members))) + (mapc (lambda (archive member target) + (require 'arc-mode) + (let* ((--quote-file-name + ;; This is shamelessly stolen from `archive-zip-extract'. + (lambda (name) + (if (or (not (memq system-type '(windows-nt ms-dos))) + (and (boundp 'w32-quote-process-args) + (null w32-quote-process-args))) + (shell-quote-argument name) + name))) + (target (funcall --quote-file-name target)) + (archive (expand-file-name archive)) + (archive-zip-extract + (list "unzip" "-qq" "-o" "-d" target)) + exit-code command-output) + (setq command-output + (with-temp-buffer + (setq exit-code (archive-zip-extract archive member)) + (buffer-string))) + (unless (zerop exit-code) + (message command-output) + (error "Extraction failed")))) + members)) + +;;;; Textbox + +(defun org-e-odt--textbox (text width height style &optional + extra anchor-type) + (org-e-odt--frame + (format "\n<draw:text-box %s>%s\n</draw:text-box>" + (concat (format " fo:min-height=\"%0.2fcm\"" (or height .2)) + (and (not width) + (format " fo:min-width=\"%0.2fcm\"" (or width .2)))) + text) + width nil style extra anchor-type)) + + + +;;;; Table of Contents + +(defun org-e-odt-begin-toc (index-title depth) + (concat + (format " + <text:table-of-content text:style-name=\"Sect2\" text:protected=\"true\" text:name=\"Table of Contents1\"> + <text:table-of-content-source text:outline-level=\"%d\"> + <text:index-title-template text:style-name=\"Contents_20_Heading\">%s</text:index-title-template> +" depth index-title) + + (let ((levels (number-sequence 1 10))) + (mapconcat + (lambda (level) + (format + " + <text:table-of-content-entry-template text:outline-level=\"%d\" text:style-name=\"Contents_20_%d\"> + <text:index-entry-link-start text:style-name=\"Internet_20_link\"/> + <text:index-entry-chapter/> + <text:index-entry-text/> + <text:index-entry-link-end/> + </text:table-of-content-entry-template> +" level level)) levels "")) + + (format " + </text:table-of-content-source> + + <text:index-body> + <text:index-title text:style-name=\"Sect1\" text:name=\"Table of Contents1_Head\"> + <text:p text:style-name=\"Contents_20_Heading\">%s</text:p> + </text:index-title> + " index-title))) + +(defun org-e-odt-end-toc () + (format " + </text:index-body> + </text:table-of-content> +")) + + + +(defun* org-e-odt-format-toc-headline + (todo todo-type priority text tags + &key level section-number headline-label &allow-other-keys) + (setq text (concat + (and org-export-with-section-numbers + (concat section-number ". ")) + text + (and tags + (concat + "<text:tab/>" + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTag" tags))))) + (when todo + (setq text (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTodo" text))) + (org-e-odt-format-link text (concat "#" headline-label) t)) + +(defun org-e-odt-toc (depth info) + (assert (wholenump depth)) + (let* ((title (org-export-translate "Table of Contents" :utf-8 info)) + (headlines (org-export-collect-headlines info depth))) + + (when headlines + (concat + (org-e-odt-begin-toc title depth) + + (mapconcat + (lambda (headline) + (let* ((entry (org-e-odt-format-headline--wrap + headline info 'org-e-odt-format-toc-headline)) + (level (org-export-get-relative-level headline info)) + (style (format "Contents_20_%d" level))) + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + style entry))) + headlines "\n") + + (org-e-odt-end-toc))))) + + +;;;; Document styles + +(defun org-e-odt-add-automatic-style (object-type &optional object-props) + "Create an automatic style of type OBJECT-TYPE with param OBJECT-PROPS. +OBJECT-PROPS is (typically) a plist created by passing +\"#+ATTR_ODT: \" option of the object in question to +`org-e-odt-parse-block-attributes'. + +Use `org-e-odt-object-counters' to generate an automatic +OBJECT-NAME and STYLE-NAME. If OBJECT-PROPS is non-nil, add a +new entry in `org-e-odt-automatic-styles'. Return (OBJECT-NAME +. STYLE-NAME)." + (assert (stringp object-type)) + (let* ((object (intern object-type)) + (seqvar object) + (seqno (1+ (or (plist-get org-e-odt-object-counters seqvar) 0))) + (object-name (format "%s%d" object-type seqno)) style-name) + (setq org-e-odt-object-counters + (plist-put org-e-odt-object-counters seqvar seqno)) + (when object-props + (setq style-name (format "Org%s" object-name)) + (setq org-e-odt-automatic-styles + (plist-put org-e-odt-automatic-styles object + (append (list (list style-name object-props)) + (plist-get org-e-odt-automatic-styles object))))) + (cons object-name style-name))) + + +;;;; Caption and Labels + + +(defun org-e-odt--wrap-label (element output) + "Wrap label associated to ELEMENT around OUTPUT, if appropriate. +This function shouldn't be used for floats. See +`org-e-odt--caption/label-string'." + ;; (let ((label (org-element-property :name element))) + ;; (if (or (not output) (not label) (string= output "") (string= label "")) + ;; output + ;; (concat (format "\\label{%s}\n" label) output))) + output) + + +(defun org-e-odt--caption/label-string (caption label info) + "Return caption and label HTML string for floats. + +CAPTION is a cons cell of secondary strings, the car being the +standard caption and the cdr its short form. LABEL is a string +representing the label. INFO is a plist holding contextual +information. + +If there's no caption nor label, return the empty string. + +For non-floats, see `org-e-odt--wrap-label'." + (setq label nil) ;; FIXME + + (let ((label-str (if label (format "\\label{%s}" label) ""))) + (cond + ((and (not caption) (not label)) "") + ((not caption) (format "\\label{%s}\n" label)) + ;; Option caption format with short name. + ((cdr caption) + (format "\\caption[%s]{%s%s}\n" + (org-export-data (cdr caption) info) + label-str + (org-export-data (car caption) info))) + ;; Standard caption format. + ;; (t (format "\\caption{%s%s}\n" + ;; label-str + ;; (org-export-data (car caption) info))) + (t (org-export-data (car caption) info))))) + +;;;; Checkbox + +(defun org-e-odt--checkbox (item) + "Return check-box string associated to ITEM." + (let ((checkbox (org-element-property :checkbox item))) + (if (not checkbox) "" + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgCode" (case checkbox + (on "[✓] ") ; CHECK MARK + (off "[ ] ") + (trans "[-] ")))))) + + + +;;; Template + +(defun org-e-odt-template (contents info) + "Return complete document string after HTML conversion. +CONTENTS is the transcoded contents string. RAW-DATA is the +original parsed data. INFO is a plist holding export options." + ;; Write meta file. + (let ((title (org-export-data (plist-get info :title) info)) + (author (let ((author (plist-get info :author))) + (if (not author) "" (org-export-data author info)))) + (date (org-e-odt--date + (org-export-data (plist-get info :date) info))) + (email (plist-get info :email)) + (keywords (plist-get info :keywords)) + (description (plist-get info :description))) + (write-region + (concat + "<?xml version=\"1.0\" encoding=\"UTF-8\"?> + <office:document-meta + xmlns:office=\"urn:oasis:names:tc:opendocument:xmlns:office:1.0\" + xmlns:xlink=\"http://www.w3.org/1999/xlink\" + xmlns:dc=\"http://purl.org/dc/elements/1.1/\" + xmlns:meta=\"urn:oasis:names:tc:opendocument:xmlns:meta:1.0\" + xmlns:ooo=\"http://openoffice.org/2004/office\" + office:version=\"1.2\"> + <office:meta>\n" + (format "<dc:creator>%s</dc:creator>\n" author) + (format "<meta:initial-creator>%s</meta:initial-creator>\n" author) + (format "<dc:date>%s</dc:date>\n" date) + (format "<meta:creation-date>%s</meta:creation-date>\n" date) + (format "<meta:generator>%s</meta:generator>\n" + (let ((creator-info (plist-get info :with-creator))) + (if (or (not creator-info) (eq creator-info 'comment)) "" + (plist-get info :creator)))) + (format "<meta:keyword>%s</meta:keyword>\n" keywords) + (format "<dc:subject>%s</dc:subject>\n" description) + (format "<dc:title>%s</dc:title>\n" title) + "\n" + " </office:meta>\n" "</office:document-meta>") + nil (concat org-e-odt-zip-dir "meta.xml")) + ;; Add meta.xml in to manifest. + (org-e-odt-create-manifest-file-entry "text/xml" "meta.xml")) + + ;; Update styles file. + ;; Copy styles.xml. Also dump htmlfontify styles, if there is any. + ;; Write styles file. + (let* ((styles-file (plist-get info :odt-styles-file)) + (styles-file (and styles-file (read (org-trim styles-file)))) + ;; Non-availability of styles.xml is not a critical + ;; error. For now throw an error purely for aesthetic + ;; reasons. + (styles-file (or styles-file + org-e-odt-styles-file + (expand-file-name "OrgOdtStyles.xml" + org-e-odt-styles-dir) + (error "org-e-odt: Missing styles file?")))) + (cond + ((listp styles-file) + (let ((archive (nth 0 styles-file)) + (members (nth 1 styles-file))) + (org-e-odt--zip-extract archive members org-e-odt-zip-dir) + (mapc + (lambda (member) + (when (org-file-image-p member) + (let* ((image-type (file-name-extension member)) + (media-type (format "image/%s" image-type))) + (org-e-odt-create-manifest-file-entry media-type member)))) + members))) + ((and (stringp styles-file) (file-exists-p styles-file)) + (let ((styles-file-type (file-name-extension styles-file))) + (cond + ((string= styles-file-type "xml") + (copy-file styles-file (concat org-e-odt-zip-dir "styles.xml") t)) + ((member styles-file-type '("odt" "ott")) + (org-e-odt--zip-extract styles-file "styles.xml" org-e-odt-zip-dir))))) + (t + (error (format "Invalid specification of styles.xml file: %S" + org-e-odt-styles-file)))) + + ;; create a manifest entry for styles.xml + (org-e-odt-create-manifest-file-entry "text/xml" "styles.xml") + + ;; FIXME: Who is opening an empty styles.xml before this point? + (with-current-buffer + (find-file-noselect (concat org-e-odt-zip-dir "styles.xml") t) + (revert-buffer t t) + + ;; Write custom styles for source blocks + ;; Save STYLES used for colorizing of source blocks. + ;; Update styles.xml with styles that were collected as part of + ;; `org-e-odt-hfy-face-to-css' callbacks. + (let ((styles (mapconcat (lambda (style) (format " %s\n" (cddr style))) + hfy-user-sheet-assoc ""))) + (when styles + (goto-char (point-min)) + (when (re-search-forward "</office:styles>" nil t) + (goto-char (match-beginning 0)) + (insert "\n<!-- Org Htmlfontify Styles -->\n" styles "\n")))) + + ;; Update styles.xml - take care of outline numbering + + ;; Don't make automatic backup of styles.xml file. This setting + ;; prevents the backed-up styles.xml file from being zipped in to + ;; odt file. This is more of a hackish fix. Better alternative + ;; would be to fix the zip command so that the output odt file + ;; includes only the needed files and excludes any auto-generated + ;; extra files like backups and auto-saves etc etc. Note that + ;; currently the zip command zips up the entire temp directory so + ;; that any auto-generated files created under the hood ends up in + ;; the resulting odt file. + (set (make-local-variable 'backup-inhibited) t) + + ;; Outline numbering is retained only upto LEVEL. + ;; To disable outline numbering pass a LEVEL of 0. + + (goto-char (point-min)) + (let ((regex + "<text:outline-level-style\\([^>]*\\)text:level=\"\\([^\"]*\\)\"\\([^>]*\\)>") + (replacement + "<text:outline-level-style\\1text:level=\"\\2\" style:num-format=\"\">")) + (while (re-search-forward regex nil t) + (unless (let ((sec-num (plist-get info :section-numbers)) + (level (string-to-number (match-string 2)))) + (if (wholenump sec-num) (<= level sec-num) sec-num)) + (replace-match replacement t nil)))) + (save-buffer 0))) + ;; Update content.xml. + (with-temp-buffer + (insert-file-contents + (or org-e-odt-content-template-file + (expand-file-name "OrgOdtContentTemplate.xml" + org-e-odt-styles-dir))) + ;; Write automatic styles. + ;; - Position the cursor. + (goto-char (point-min)) + (re-search-forward " </office:automatic-styles>" nil t) + (goto-char (match-beginning 0)) + ;; - Dump automatic table styles + (loop for (style-name props) in + (plist-get org-e-odt-automatic-styles 'Table) do + (when (setq props (or (plist-get props :rel-width) 96)) + (insert (format org-e-odt-table-style-format style-name props)))) + ;; Update display level. + ;; - Remove existing sequence decls. Also position the cursor. + (goto-char (point-min)) + (when (re-search-forward "<text:sequence-decls" nil t) + (delete-region (match-beginning 0) + (re-search-forward "</text:sequence-decls>" nil nil))) + ;; Update sequence decls according to user preference. + (insert + (format + "\n<text:sequence-decls>\n%s\n</text:sequence-decls>" + (mapconcat + (lambda (x) + (format + "<text:sequence-decl text:display-outline-level=\"%d\" text:name=\"%s\"/>" + org-e-odt-display-outline-level (nth 1 x))) + org-e-odt-category-map-alist "\n"))) + ;; Position the cursor to document body. + (goto-char (point-min)) + (re-search-forward "</office:text>" nil nil) + (goto-char (match-beginning 0)) + + ;; Preamble - Title, Author, Date etc. + (insert + (let* ((title (org-export-data (plist-get info :title) info)) + (author (and (plist-get info :with-author) + (let ((auth (plist-get info :author))) + (and auth (org-export-data auth info))))) + (date (org-export-data (plist-get info :date) info)) + (iso-date (org-e-odt--date date)) + (date (org-e-odt--date date "%d %b %Y")) + (email (plist-get info :email)) + ;; switch on or off above vars based on user settings + (author (and (plist-get info :with-author) (or author email))) + ;; (date (and (plist-get info :time-stamp-file) date)) + (email (and (plist-get info :with-email) email))) + (concat + ;; title + (when title + (concat + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "OrgTitle" (format "\n<text:title>%s</text:title>" title)) + ;; separator + "\n<text:p text:style-name=\"OrgTitle\"/>")) + (cond + ((and author (not email)) + ;; author only + (concat + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "OrgSubtitle" + (format "<text:initial-creator>%s</text:initial-creator>" author)) + ;; separator + "\n<text:p text:style-name=\"OrgSubtitle\"/>")) + ((and author email) + ;; author and email + (concat + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "OrgSubtitle" + (org-e-odt-format-link + (format "<text:initial-creator>%s</text:initial-creator>" author) + (concat "mailto:" email))) + ;; separator + "\n<text:p text:style-name=\"OrgSubtitle\"/>"))) + ;; date + (when date + (concat + (format + "\n<text:p text:style-name=\"%s\">%s</text:p>" + "OrgSubtitle" + (format + "\n<text:date style:data-style-name=\"%s\" text:date-value=\"%s\">%s</text:date>" + + "N75" iso-date date)) + ;; separator + "<text:p text:style-name=\"OrgSubtitle\"/>"))))) + + ;; Table of Contents + (let ((depth (plist-get info :with-toc))) + (when (wholenump depth) (insert (org-e-odt-toc depth info)))) + ;; Contents. + (insert contents) + ;; Return contents. + (buffer-substring-no-properties (point-min) (point-max)))) + + + +;;; Transcode Functions + +;;;; Bold + +(defun org-e-odt-bold (bold contents info) + "Transcode BOLD from Org to ODT. +CONTENTS is the text with bold markup. INFO is a plist holding +contextual information." + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "Bold" contents)) + + +;;;; Center Block + +(defun org-e-odt-center-block (center-block contents info) + "Transcode a CENTER-BLOCK element from Org to ODT. +CONTENTS holds the contents of the center block. INFO is a plist +holding contextual information." + (org-e-odt--wrap-label center-block contents)) + + +;;;; Clock + +(defun org-e-odt-clock (clock contents info) + "Transcode a CLOCK element from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestampWrapper" + (concat + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestampKeyword" org-clock-string) + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestamp" + (concat (org-translate-time + (org-element-property :value clock)) + (let ((time (org-element-property :time clock))) + (and time (format " (%s)" time)))))))) + + +;;;; Code + +(defun org-e-odt-code (code contents info) + "Transcode a CODE object from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgCode" (org-element-property :value code))) + + +;;;; Comment + +;; Comments are ignored. + + +;;;; Comment Block + +;; Comment Blocks are ignored. + + +;;;; Drawer + +(defun org-e-odt-drawer (drawer contents info) + "Transcode a DRAWER element from Org to ODT. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let* ((name (org-element-property :drawer-name drawer)) + (output (if (functionp org-e-odt-format-drawer-function) + (funcall org-e-odt-format-drawer-function + name contents) + ;; If there's no user defined function: simply + ;; display contents of the drawer. + contents))) + (org-e-odt--wrap-label drawer output))) + + +;;;; Dynamic Block + +(defun org-e-odt-dynamic-block (dynamic-block contents info) + "Transcode a DYNAMIC-BLOCK element from Org to ODT. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information. See `org-export-data'." + (org-e-odt--wrap-label dynamic-block contents)) + + +;;;; Entity + +(defun org-e-odt-entity (entity contents info) + "Transcode an ENTITY object from Org to ODT. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + ;; (let ((ent (org-element-property :latex entity))) + ;; (if (org-element-property :latex-math-p entity) + ;; (format "$%s$" ent) + ;; ent)) + (org-element-property :utf-8 entity)) + + +;;;; Example Block + +(defun org-e-odt-example-block (example-block contents info) + "Transcode a EXAMPLE-BLOCK element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-odt--wrap-label + example-block (org-e-odt-format-code example-block info))) + + +;;;; Export Snippet + +(defun org-e-odt-export-snippet (export-snippet contents info) + "Transcode a EXPORT-SNIPPET object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (eq (org-export-snippet-backend export-snippet) 'e-odt) + (org-element-property :value export-snippet))) + + +;;;; Export Block + +(defun org-e-odt-export-block (export-block contents info) + "Transcode a EXPORT-BLOCK element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (string= (org-element-property :type export-block) "ODT") + (org-remove-indentation (org-element-property :value export-block)))) + + +;;;; Fixed Width + +(defun org-e-odt-fixed-width (fixed-width contents info) + "Transcode a FIXED-WIDTH element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-odt--wrap-label + fixed-width (org-e-odt-do-format-code + (org-element-property :value fixed-width)))) + + +;;;; Footnote Definition + +;; Footnote Definitions are ignored. + + +;;;; Footnote Reference + +(defun org-e-odt-footnote-reference (footnote-reference contents info) + "Transcode a FOOTNOTE-REFERENCE element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((--format-footnote-definition + (function + (lambda (n def) + (setq n (format "%d" n)) + (let ((id (concat "fn" n)) + (note-class "footnote") + (par-style "Footnote")) + (format + "<text:note text:id=\"%s\" text:note-class=\"%s\">%s</text:note>" + id note-class + (concat + (format "<text:note-citation>%s</text:note-citation>" n) + (format "<text:note-body>%s</text:note-body>" def))))))) + (--format-footnote-reference + (function + (lambda (n) + (setq n (format "%d" n)) + (let ((note-class "footnote") + (ref-format "text") + (ref-name (concat "fn" n))) + (format + "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgSuperscript" + (format "<text:note-ref text:note-class=\"%s\" text:reference-format=\"%s\" text:ref-name=\"%s\">%s</text:note-ref>" + note-class ref-format ref-name n))))))) + (concat + ;; Insert separator between two footnotes in a row. + (let ((prev (org-export-get-previous-element footnote-reference info))) + (and (eq (org-element-type prev) 'footnote-reference) + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgSuperscript" ","))) + ;; Trancode footnote reference. + (let ((n (org-export-get-footnote-number footnote-reference info))) + (cond + ((not (org-export-footnote-first-reference-p footnote-reference info)) + (funcall --format-footnote-reference n)) + ;; Inline definitions are secondary strings. + ;; Non-inline footnotes definitions are full Org data. + (t + (let* ((raw (org-export-get-footnote-definition footnote-reference + info)) + (def (let ((def (org-trim (org-export-data raw info)))) + (if (eq (org-element-type raw) 'org-data) def + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Footnote" def))))) + (funcall --format-footnote-definition n def)))))))) + + +;;;; Headline + +(defun* org-e-odt-format-headline + (todo todo-type priority text tags + &key level section-number headline-label &allow-other-keys) + (concat + ;; Todo. + (and todo + (concat + (let ((style (if (member todo org-done-keywords) "OrgDone" "OrgTodo"))) + (format "<text:span text:style-name=\"%s\">%s</text:span>" + style todo)) " ")) + ;; Title. + text + ;; Tags. + (and tags + (concat "<text:tab/>" + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTag" (mapconcat 'org-trim tags " : ")))))) + +(defun org-e-odt-format-headline--wrap (headline info + &optional format-function + &rest extra-keys) + "Transcode an HEADLINE element from Org to ODT. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((level (+ (org-export-get-relative-level headline info))) + (headline-number (org-export-get-headline-number headline info)) + (section-number (and (org-export-numbered-headline-p headline info) + (mapconcat 'number-to-string + headline-number "."))) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + (text (org-export-data (org-element-property :title headline) info)) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (headline-label (concat "sec-" (mapconcat 'number-to-string + headline-number "-"))) + (format-function (cond + ((functionp format-function) format-function) + ((functionp org-e-odt-format-headline-function) + (function* + (lambda (todo todo-type priority text tags + &allow-other-keys) + (funcall org-e-odt-format-headline-function + todo todo-type priority text tags)))) + (t 'org-e-odt-format-headline)))) + (apply format-function + todo todo-type priority text tags + :headline-label headline-label :level level + :section-number section-number extra-keys))) + + +(defun org-e-odt-begin-plain-list (ltype &optional continue-numbering) + (unless (member ltype '(ordered unordered descriptive)) + (error "Unknown list type: %s" ltype)) + (let ((style-name (assoc-default ltype + '((ordered . "OrgNumberedList") + (unordered . "OrgBulletedList") + (descriptive . "OrgDescriptionList"))))) + (format "<text:list text:style-name=\"%s\" text:continue-numbering=\"%s\">" + style-name (if continue-numbering "true" "false")))) + +(defun org-e-odt-headline (headline contents info) + "Transcode an HEADLINE element from Org to ODT. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((numberedp (org-export-numbered-headline-p headline info)) + ;; Get level relative to current parsed data. + (level (org-export-get-relative-level headline info)) + (text (org-export-data (org-element-property :title headline) info)) + ;; Create the headline text. + (full-text (org-e-odt-format-headline--wrap headline info))) + (cond + ;; Case 1: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + ;; Case 2. This is a deep sub-tree: export it as a list item. + ;; Also export as items headlines for which no section + ;; format has been found. + ;; FIXME + ;; ((org-export-low-level-p headline info) + ;; ;; Build the real contents of the sub-tree. + ;; (let* ((type (if numberedp 'unordered 'unordered)) ; FIXME + ;; (itemized-body (org-e-odt-format-list-item + ;; contents type nil nil full-text))) + ;; (concat + ;; (and (org-export-first-sibling-p headline info) + ;; (org-e-odt-begin-plain-list type)) + ;; itemized-body + ;; (and (org-export-last-sibling-p headline info) + ;; "</text:list>")))) + ;; Case 3. Standard headline. Export it as a section. + (t + (let* ((extra-ids (list (org-element-property :custom-id headline) + (org-element-property :id headline))) + (extra-ids nil) ; FIXME + (id (concat "sec-" (mapconcat 'number-to-string + (org-export-get-headline-number + headline info) "-")))) + (concat + (format + "\n<text:h text:style-name=\"%s\" text:outline-level=\"%s\">%s%s</text:h>" + (format "Heading_20_%s" level) + level + ;; Extra targets. + (mapconcat (lambda (x) + (when x + (let ((x (if (org-uuidgen-p x) (concat "ID-" x) x))) + (org-e-odt-format-target + "" (org-export-solidify-link-text x))))) + extra-ids "") + ;; Title. + (org-e-odt-format-target full-text id)) + contents)))))) + + +;;;; Horizontal Rule + +(defun org-e-odt-horizontal-rule (horizontal-rule contents info) + "Transcode an HORIZONTAL-RULE object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-odt--wrap-label + horizontal-rule + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Horizontal_20_Line" ""))) + + +;;;; Inline Babel Call + +;; Inline Babel Calls are ignored. + + +;;;; Inline Src Block + +(defun org-e-odt--find-verb-separator (s) + "Return a character not used in string S. +This is used to choose a separator for constructs like \\verb." + (let ((ll "~,./?;':\"|!@#%^&-_=+abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ<>()[]{}")) + (loop for c across ll + when (not (string-match (regexp-quote (char-to-string c)) s)) + return (char-to-string c)))) + +(defun org-e-odt-inline-src-block (inline-src-block contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to ODT. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((org-lang (org-element-property :language inline-src-block)) + (code (org-element-property :value inline-src-block)) + (separator (org-e-odt--find-verb-separator code))) + (error "FIXME"))) + + +;;;; Inlinetask + +(defun org-e-odt-inlinetask (inlinetask contents info) + "Transcode an INLINETASK element from Org to ODT. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (cond + ;; If `org-e-odt-format-inlinetask-function' is provided, call it + ;; with appropriate arguments. + ((functionp org-e-odt-format-inlinetask-function) + (let ((format-function + (function* + (lambda (todo todo-type priority text tags + &key contents &allow-other-keys) + (funcall org-e-odt-format-inlinetask-function + todo todo-type priority text tags contents))))) + (org-e-odt-format-headline--wrap + inlinetask info format-function :contents contents))) + ;; Otherwise, use a default template. + (t (org-e-odt--wrap-label + inlinetask + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Text_20_body" + (org-e-odt--textbox + (concat + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "OrgInlineTaskHeading" + (org-e-odt-format-headline--wrap + inlinetask info)) + contents) + nil nil "OrgInlineTaskFrame" " style:rel-width=\"100%\"")))))) + +;;;; Italic + +(defun org-e-odt-italic (italic contents info) + "Transcode ITALIC from Org to ODT. +CONTENTS is the text with italic markup. INFO is a plist holding +contextual information." + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "Emphasis" contents)) + + +;;;; Item + +(defun org-e-odt-item (item contents info) + "Transcode an ITEM element from Org to ODT. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((plain-list (org-export-get-parent item)) + (type (org-element-property :type plain-list)) + (counter (org-element-property :counter item)) + (tag (let ((tag (org-element-property :tag item))) + (and tag + (concat (org-e-odt--checkbox item) + (org-export-data tag info)))))) + (case type + ((ordered unordered) + (format "\n<text:list-item>\n%s\n%s" + contents + (let* ((--element-has-a-table-p + (function + (lambda (element info) + (loop for el in (org-element-contents element) + thereis (eq (org-element-type el) 'table)))))) + (cond + ((funcall --element-has-a-table-p item info) + "</text:list-header>") + (t "</text:list-item>"))))) + (descriptive + (concat + (let ((term (or tag "(no term)"))) + (concat + (format "\n<text:list-item>\n%s\n</text:list-item>" + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Text_20_body_20_bold" term)) + (format + "\n<text:list-item>\n%s\n</text:list-item>" + (format "\n<text:list text:style-name=\"%s\" %s>\n%s\n</text:list>" + "OrgDescriptionList" + "text:continue-numbering=\"false\"" + (format "\n<text:list-item>\n%s\n</text:list-item>" + contents))))))) + (t (error "Unknown list type: %S" type))))) + + +;;;; Keyword + +(defun org-e-odt-keyword (keyword contents info) + "Transcode a KEYWORD element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + (cond + ((string= key "LATEX") value) + ((string= key "INDEX") (format "\\index{%s}" value)) + ((string= key "TARGET") nil ; FIXME + ;; (format "\\label{%s}" (org-export-solidify-link-text value)) + ) + ((string= key "toc") + (let ((value (downcase value))) + (cond + ((string-match "\\<headlines\\>" value) + (let ((depth (or (and (string-match "[0-9]+" value) + (string-to-number (match-string 0 value))) + (plist-get info :with-toc)))) + (when (wholenump depth) (org-e-odt-toc depth info)))) + ((string= "tables" value) "FIXME") + ((string= "figures" value) "FIXME") + ((string= "listings" value) + (cond + ;; At the moment, src blocks with a caption are wrapped + ;; into a figure environment. + (t "FIXME"))))))))) + + +;;;; Latex Environment + + +(eval-after-load 'org-odt + '(ad-deactivate 'org-format-latex-as-mathml)) + +;; (defadvice org-format-latex-as-mathml ; FIXME +;; (after org-e-odt-protect-latex-fragment activate) +;; "Encode LaTeX fragment as XML. +;; Do this when translation to MathML fails." +;; (when (or (not (> (length ad-return-value) 0)) +;; (get-text-property 0 'org-protected ad-return-value)) +;; (setq ad-return-value +;; (org-propertize (org-e-odt-encode-plain-text (ad-get-arg 0)) +;; 'org-protected t)))) + +(defun org-e-odt-format-latex (latex-frag processing-type info) + (let* ((prefix (case processing-type + (dvipng "ltxpng/") + (mathml "ltxmathml/"))) + (input-file (plist-get info :input-file)) + (cache-subdir + (concat prefix (file-name-sans-extension + (file-name-nondirectory input-file)))) + (cache-dir (file-name-directory input-file)) + (display-msg (case processing-type + (dvipng "Creating LaTeX Image...") + (mathml "Creating MathML snippet...")))) + (with-temp-buffer + (insert latex-frag) + (org-format-latex cache-subdir cache-dir nil display-msg + nil nil processing-type) + (buffer-string)))) + +(defun org-e-odt-latex-environment (latex-environment contents info) + "Transcode a LATEX-ENVIRONMENT element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-e-odt--wrap-label + latex-environment + (let* ((latex-frag + (org-remove-indentation + (org-element-property :value latex-environment))) + (processing-type (plist-get info :LaTeX-fragments)) + (caption (org-element-property :caption latex-environment)) + (short-caption (and (cdr caption) + (org-export-data (cdr caption) info))) + (caption (and (car caption) (org-export-data (car caption) info))) + (label (org-element-property :name latex-environment)) + (attr nil) ; FIXME + (label (org-element-property :name latex-environment))) + + (when (memq processing-type '(t mathjax)) + (unless (and (fboundp 'org-format-latex-mathml-available-p) + (org-format-latex-mathml-available-p)) + (message "LaTeX to MathML converter not available. Trying dvinpng...") + (setq processing-type 'dvipng))) + + (when (eq processing-type 'dvipng) + (unless (and (org-check-external-command "latex" "" t) + (org-check-external-command "dvipng" "" t)) + (message "LaTeX to PNG converter not available. Using verbatim.") + (setq processing-type 'verbatim))) + + (case processing-type + ((t mathjax) + (org-e-odt-format-formula latex-environment info)) + (dvipng + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Text_20_body" + (org-e-odt-link--inline-image latex-environment info))) + (t (org-e-odt-do-format-code latex-frag)))))) + + +;;;; Latex Fragment + + +;; (when latex-frag ; FIXME +;; (setq href (org-propertize href :title "LaTeX Fragment" +;; :description latex-frag))) +;; handle verbatim +;; provide descriptions + +(defun org-e-odt-latex-fragment (latex-fragment contents info) + "Transcode a LATEX-FRAGMENT object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (let* ((latex-frag (org-element-property :value latex-fragment)) + (processing-type (plist-get info :LaTeX-fragments))) + (cond + ((member processing-type '(t mathjax)) + (org-e-odt-format-formula latex-fragment info)) + ((eq processing-type 'dvipng) + (org-e-odt-link--inline-image latex-fragment info)) + (t (org-e-odt-encode-plain-text latex-frag t))))) + + +;;;; Line Break + +(defun org-e-odt-line-break (line-break contents info) + "Transcode a LINE-BREAK object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + "<text:line-break/>\n") + + +;;;; Link + + + +;;;; Links :: Generic + +(defun org-e-odt-format-link (desc href &optional suppress-xref) + (cond + ((and (= (string-to-char href) ?#) (not suppress-xref)) + (setq href (substring href 1)) + (let ((xref-format "text")) + (when (numberp desc) + (setq desc (format "%d" desc) xref-format "number")) + (when (listp desc) + (setq desc (mapconcat 'number-to-string desc ".") xref-format "chapter")) + (setq href (concat org-e-odt-bookmark-prefix href)) + (format + "<text:bookmark-ref text:reference-format=\"%s\" text:ref-name=\"%s\">%s</text:bookmark-ref>" + xref-format href desc))) + ;; (org-lparse-link-description-is-image + ;; (format "\n<draw:a xlink:type=\"simple\" xlink:href=\"%s\">\n%s\n</draw:a>" + ;; href desc)) + (t (format "<text:a xlink:type=\"simple\" xlink:href=\"%s\">%s</text:a>" + href desc)))) + +(defun org-e-odt-format-internal-link (text href) + (org-e-odt-format-link text (concat "#" href))) + +;;;; Links :: Label references + +(defun org-e-odt-enumerate-element (element info &optional predicate n) + (let* ((--numbered-parent-headline-at-<=-n + (function + (lambda (element n info) + (loop for x in (org-export-get-genealogy element) + thereis (and (eq (org-element-type x) 'headline) + (<= (org-export-get-relative-level x info) n) + (org-export-numbered-headline-p x info) + x))))) + (--enumerate + (function + (lambda (element scope info &optional predicate) + (let ((counter 0)) + (org-element-map + (or scope (plist-get info :parse-tree)) + (org-element-type element) + (lambda (el) + (and (or (not predicate) (funcall predicate el info)) + (incf counter) + (eq element el) + counter)) + info 'first-match))))) + (scope (funcall --numbered-parent-headline-at-<=-n + element (or n org-e-odt-display-outline-level) info)) + (ordinal (funcall --enumerate element scope info predicate)) + (tag + (concat + ;; Section number. + (and scope + (mapconcat 'number-to-string + (org-export-get-headline-number scope info) ".")) + ;; Separator. + (and scope ".") + ;; Ordinal. + (number-to-string ordinal)))) + tag)) + +(defun org-e-odt-format-label (element info op) + (let* ((caption-from + (case (org-element-type element) + (link (org-export-get-parent-element element)) + (t element))) + ;; get label and caption. + (label (org-element-property :name caption-from)) + (caption (org-element-property :caption caption-from)) + (short-caption (cdr caption)) + ;; transcode captions. + (caption (and (car caption) (org-export-data (car caption) info))) + (short-caption (and short-caption + (org-export-data short-caption info)))) + (when (or label caption) + (let* ((default-category + (cond + ((eq (org-element-type element) 'table) + "__Table__") + ((org-e-odt-standalone-image-p element info) + "__Figure__") + ((member (org-element-type element) + '(latex-environment latex-fragment)) + (let ((processing-type (plist-get info :LaTeX-fragments))) + (cond + ((eq processing-type 'dvipng) "__DvipngImage__") + ((eq processing-type 'mathjax) "__MathFormula__") + ((eq processing-type 't) "__MathFormula__") + (t (error "Handle LaTeX:verbatim"))))) + ((eq (org-element-type element) 'src-block) + "__Listing__") + (t (error "Handle enumeration of %S" element)))) + (predicate + (cond + ((member (org-element-type element) + '(table latex-environment src-block)) + nil) + ((org-e-odt-standalone-image-p element info) + 'org-e-odt-standalone-image-p) + (t (error "Handle enumeration of %S" element)))) + (seqno (org-e-odt-enumerate-element + element info predicate)) ; FIXME + ;; handle label props. + (label-props (assoc default-category org-e-odt-category-map-alist)) + ;; identify opendocument counter + (counter (nth 1 label-props)) + ;; identify label style + (label-style (nth 2 label-props)) + ;; retrieve localized category sting + (category (org-export-translate (nth 3 label-props) :utf-8 info))) + (case op + (definition + ;; assign an internal label, if user has not provided one + (setq label (or label (format "%s-%s" default-category seqno))) + (setq label (org-export-solidify-link-text label)) + + (cons + (format-spec + (cadr (assoc-string label-style org-e-odt-label-styles t)) + `((?e . ,category) + (?n . ,(format + "<text:sequence text:ref-name=\"%s\" text:name=\"%s\" text:formula=\"ooow:%s+1\" style:num-format=\"1\">%s</text:sequence>" + label counter counter seqno)) + (?c . ,(or caption "")))) + short-caption)) + (reference + (assert label) + (setq label (org-export-solidify-link-text label)) + (let* ((fmt (cddr (assoc-string label-style org-e-odt-label-styles t))) + (fmt1 (car fmt)) + (fmt2 (cadr fmt))) + (format "<text:sequence-ref text:reference-format=\"%s\" text:ref-name=\"%s\">%s</text:sequence-ref>" + fmt1 label (format-spec fmt2 `((?e . ,category) + (?n . ,seqno)))))) + (t (error "Unknow %S on label" op))))))) + +;;;; Links :: Embedded images + +(defun org-e-odt-copy-image-file (path) + "Returns the internal name of the file" + (let* ((image-type (file-name-extension path)) + (media-type (format "image/%s" image-type)) + (target-dir "Images/") + (target-file + (format "%s%04d.%s" target-dir + (incf org-e-odt-embedded-images-count) image-type))) + (message "Embedding %s as %s ..." + (substring-no-properties path) target-file) + + (when (= 1 org-e-odt-embedded-images-count) + (make-directory (concat org-e-odt-zip-dir target-dir)) + (org-e-odt-create-manifest-file-entry "" target-dir)) + + (copy-file path (concat org-e-odt-zip-dir target-file) 'overwrite) + (org-e-odt-create-manifest-file-entry media-type target-file) + target-file)) + +(defun org-e-odt-image-size-from-file (file &optional user-width + user-height scale dpi embed-as) + (let* ((--pixels-to-cms + (function (lambda (pixels dpi) + (let ((cms-per-inch 2.54) + (inches (/ pixels dpi))) + (* cms-per-inch inches))))) + (--size-in-cms + (function + (lambda (size-in-pixels dpi) + (and size-in-pixels + (cons (funcall --pixels-to-cms (car size-in-pixels) dpi) + (funcall --pixels-to-cms (cdr size-in-pixels) dpi)))))) + (dpi (or dpi org-e-odt-pixels-per-inch)) + (anchor-type (or embed-as "paragraph")) + (user-width (and (not scale) user-width)) + (user-height (and (not scale) user-height)) + (size + (and + (not (and user-height user-width)) + (or + ;; Use Imagemagick. + (and (executable-find "identify") + (let ((size-in-pixels + (let ((dim (shell-command-to-string + (format "identify -format \"%%w:%%h\" \"%s\"" + file)))) + (when (string-match "\\([0-9]+\\):\\([0-9]+\\)" dim) + (cons (string-to-number (match-string 1 dim)) + (string-to-number (match-string 2 dim))))))) + (funcall --size-in-cms size-in-pixels dpi))) + ;; Use Emacs. + (let ((size-in-pixels + (ignore-errors ; Emacs could be in batch mode + (clear-image-cache) + (image-size (create-image file) 'pixels)))) + (funcall --size-in-cms size-in-pixels dpi)) + ;; Use hard-coded values. + (cdr (assoc-string anchor-type + org-e-odt-default-image-sizes-alist)) + ;; Error out. + (error "Cannot determine image size, aborting")))) + (width (car size)) (height (cdr size))) + (cond + (scale + (setq width (* width scale) height (* height scale))) + ((and user-height user-width) + (setq width user-width height user-height)) + (user-height + (setq width (* user-height (/ width height)) height user-height)) + (user-width + (setq height (* user-width (/ height width)) width user-width)) + (t (ignore))) + ;; ensure that an embedded image fits comfortably within a page + (let ((max-width (car org-e-odt-max-image-size)) + (max-height (cdr org-e-odt-max-image-size))) + (when (or (> width max-width) (> height max-height)) + (let* ((scale1 (/ max-width width)) + (scale2 (/ max-height height)) + (scale (min scale1 scale2))) + (setq width (* scale width) height (* scale height))))) + (cons width height))) + +;;;; Links :: Math formula + +(defun org-e-odt-format-formula (element info) + (let* ((src (cond + ((eq (org-element-type element) 'link) ; FIXME + (let* ((type (org-element-property :type element)) + (raw-path (org-element-property :path element))) + (cond + ((file-name-absolute-p raw-path) + (expand-file-name raw-path)) + (t raw-path)))) + ((member (org-element-type element) + '(latex-fragment latex-environment)) + (let* ((latex-frag (org-remove-indentation + (org-element-property :value element))) + (formula-link (org-e-odt-format-latex + latex-frag 'mathml info))) + (and formula-link + (string-match "file:\\([^]]*\\)" formula-link) + (match-string 1 formula-link)))) + (t (error "what is this?")))) + (full-src (if (file-name-absolute-p src) src + (expand-file-name src (file-name-directory + (plist-get info :input-file))))) + (caption-from + (case (org-element-type element) + (link (org-export-get-parent-element element)) + (t element))) + (captions (org-e-odt-format-label caption-from info 'definition)) + (caption (car captions)) + (href + (format "\n<draw:object %s xlink:href=\"%s\" xlink:type=\"simple\"/>" + " xlink:show=\"embed\" xlink:actuate=\"onLoad\"" + (file-name-directory (org-e-odt-copy-formula-file full-src)))) + (embed-as (if caption 'paragraph 'character)) + width height) + (cond + ((eq embed-as 'character) + (org-e-odt-format-entity "InlineFormula" href width height)) + (t + (let* ((equation (org-e-odt-format-entity + "CaptionedDisplayFormula" href width height captions)) + (label + (let* ((org-e-odt-category-map-alist + '(("__Table__" "Table" "value") + ("__Figure__" "Illustration" "value") + ("__MathFormula__" "Text" "math-label") + ("__DvipngImage__" "Equation" "value") + ("__Listing__" "Listing" "value")))) + (car (org-e-odt-format-label caption-from info 'definition)))) + (formula-tree + (org-e-odt--adopt-elements + `(table (:type org :attr_odt (":style \"OrgEquation\""))) + (org-e-odt--adopt-elements + `(table-row (:type standard)) + `(table-cell nil "<c8>") `(table-cell nil "<c1>")) + (org-e-odt--adopt-elements + `(table-row (:type standard)) + (org-e-odt--adopt-elements + `(table-cell nil) `(export-block + (:type "ODT" :value ,equation))) + (org-e-odt--adopt-elements + `(table-cell nil) `(export-block + (:type "ODT" :value ,label)))))) + (formula-info + (org-export-collect-tree-properties + formula-tree (org-export-get-environment 'e-odt)))) + (org-export-data formula-tree formula-info)))))) + +(defun org-e-odt-copy-formula-file (src-file) + "Returns the internal name of the file" + (let* ((target-dir (format "Formula-%04d/" + (incf org-e-odt-embedded-formulas-count))) + (target-file (concat target-dir "content.xml"))) + ;; Create a directory for holding formula file. Also enter it in + ;; to manifest. + (make-directory (concat org-e-odt-zip-dir target-dir)) + (org-e-odt-create-manifest-file-entry + "application/vnd.oasis.opendocument.formula" target-dir "1.2") + ;; Copy over the formula file from user directory to zip + ;; directory. + (message "Embedding %s as %s ..." src-file target-file) + (let ((case-fold-search nil)) + (cond + ;; Case 1: Mathml. + ((string-match "\\.\\(mathml\\|mml\\)\\'" src-file) + (copy-file src-file (concat org-e-odt-zip-dir target-file) 'overwrite)) + ;; Case 2: OpenDocument formula. + ((string-match "\\.odf\\'" src-file) + (org-e-odt--zip-extract src-file "content.xml" + (concat org-e-odt-zip-dir target-dir))) + (t (error "%s is not a formula file" src-file)))) + ;; Enter the formula file in to manifest. + (org-e-odt-create-manifest-file-entry "text/xml" target-file) + target-file)) + +;;;; Targets + +(defun org-e-odt-format-target (text id) + (let ((name (concat org-e-odt-bookmark-prefix id))) + (concat + (and id (format "\n<text:bookmark-start text:name=\"%s\"/>" name)) + (concat (and id (format "\n<text:bookmark text:name=\"%s\"/>" id)) text) + (and id (format "\n<text:bookmark-end text:name=\"%s\"/>" name))))) + +(defun org-e-odt-link--inline-image (element info) + "Return HTML code for an inline image. +LINK is the link pointing to the inline image. INFO is a plist +used as a communication channel." + (let* ((src (cond + ((eq (org-element-type element) 'link) + (let* ((type (org-element-property :type element)) + (raw-path (org-element-property :path element))) + (cond ((member type '("http" "https")) + (concat type ":" raw-path)) + ((file-name-absolute-p raw-path) + (expand-file-name raw-path)) + (t raw-path)))) + ((member (org-element-type element) + '(latex-fragment latex-environment)) + (let* ((latex-frag (org-remove-indentation + (org-element-property :value element))) + (formula-link (org-e-odt-format-latex + latex-frag 'dvipng info))) + (and formula-link + (string-match "file:\\([^]]*\\)" formula-link) + (match-string 1 formula-link)))) + (t (error "what is this?")))) + (src-expanded (if (file-name-absolute-p src) src + (expand-file-name src (file-name-directory + (plist-get info :input-file))))) + (href (format + "\n<draw:image xlink:href=\"%s\" xlink:type=\"simple\" xlink:show=\"embed\" xlink:actuate=\"onLoad\"/>" + (org-e-odt-copy-image-file src-expanded))) + ;; extract attributes from #+ATTR_ODT line. + (attr-from (case (org-element-type element) + (link (org-export-get-parent-element element)) + (t element))) + ;; convert attributes to a plist. + (attr-plist (org-export-read-attribute :attr_odt attr-from)) + ;; handle `:anchor', `:style' and `:attributes' properties. + (user-frame-anchor + (car (assoc-string (plist-get attr-plist :anchor) + '(("as-char") ("paragraph") ("page")) t))) + (user-frame-style + (and user-frame-anchor (plist-get attr-plist :style))) + (user-frame-attrs + (and user-frame-anchor (plist-get attr-plist :attributes))) + (user-frame-params + (list user-frame-style user-frame-attrs user-frame-anchor)) + ;; (embed-as (or embed-as user-frame-anchor "paragraph")) + ;; extrac + ;; handle `:width', `:height' and `:scale' properties. + (size (org-e-odt-image-size-from-file + src-expanded (plist-get attr-plist :width) + (plist-get attr-plist :height) + (plist-get attr-plist :scale) nil ;; embed-as + "paragraph" ; FIXME + )) + (width (car size)) (height (cdr size)) + (embed-as + (case (org-element-type element) + ((org-e-odt-standalone-image-p element info) "paragraph") + (latex-fragment "as-char") + (latex-environment "paragraph") + (t "paragraph"))) + (captions (org-e-odt-format-label element info 'definition)) + (caption (car captions)) (short-caption (cdr captions)) + (entity (concat (and caption "Captioned") embed-as "Image"))) + (org-e-odt-format-entity entity href width height + captions user-frame-params ))) + +(defun org-e-odt-format-entity (entity href width height &optional + captions user-frame-params) + (let* ((caption (car captions)) (short-caption (cdr captions)) + (entity-style (assoc-string entity org-e-odt-entity-frame-styles t)) + default-frame-params frame-params + (--merge-frame-params + (function + (lambda (default-frame-params user-frame-params) + (if (not user-frame-params) default-frame-params + (assert (= (length default-frame-params) 3)) + (assert (= (length user-frame-params) 3)) + (loop for user-frame-param in user-frame-params + for default-frame-param in default-frame-params + collect (or user-frame-param default-frame-param))))))) + (cond + ((not caption) + (setq default-frame-params (nth 2 entity-style)) + (setq frame-params (funcall --merge-frame-params + default-frame-params user-frame-params)) + (apply 'org-e-odt--frame href width height frame-params)) + (t + (setq default-frame-params (nth 3 entity-style)) + (setq frame-params (funcall --merge-frame-params + default-frame-params user-frame-params)) + (apply 'org-e-odt--textbox + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Illustration" + (concat + (apply 'org-e-odt--frame href width height + (let ((entity-style-1 (copy-sequence + (nth 2 entity-style)))) + (setcar (cdr entity-style-1) + (concat + (cadr entity-style-1) + (and short-caption + (format " draw:name=\"%s\" " + short-caption)))) + entity-style-1)) + caption)) + width height frame-params))))) + +(defun org-e-odt-standalone-image-p (element info) + "Test if ELEMENT is a standalone image for the purpose ODT export. +INFO is a plist holding contextual information. + +Return non-nil, if ELEMENT is of type paragraph and it's sole +content, save for whitespaces, is a link that qualifies as an +inline image. + +Return non-nil, if ELEMENT is of type link and it's containing +paragraph has no other content save for leading and trailing +whitespaces. + +Return nil, otherwise. + +Bind `org-e-odt-standalone-image-predicate' to constrain +paragraph further. For example, to check for only captioned +standalone images, do the following. + + \(setq org-e-odt-standalone-image-predicate + \(lambda \(paragraph\) + \(org-element-property :caption paragraph\)\)\) +" + (let ((--standalone-image-predicate + (function (lambda (paragraph) + (or (org-element-property :caption paragraph) + (org-element-property :name paragraph))))) + (paragraph (case (org-element-type element) + (paragraph element) + (link (and (org-export-inline-image-p + element org-e-odt-inline-image-rules) + (org-export-get-parent element))) + (t nil)))) + (when paragraph + (assert (eq (org-element-type paragraph) 'paragraph)) + (when (funcall --standalone-image-predicate paragraph) + (let ((contents (org-element-contents paragraph))) + (loop for x in contents + with inline-image-count = 0 + always (cond + ((eq (org-element-type x) 'plain-text) + (not (org-string-nw-p x))) + ((eq (org-element-type x) 'link) + (when (org-export-inline-image-p + x org-e-odt-inline-image-rules) + (= (incf inline-image-count) 1))) + (t nil)))))))) + +(defun org-e-odt-link (link desc info) + "Transcode a LINK object from Org to ODT. + +DESC is the description part of the link, or the empty string. +INFO is a plist holding contextual information. See +`org-export-data'." + (let* ((type (org-element-property :type link)) + (raw-path (org-element-property :path link)) + ;; Ensure DESC really exists, or set it to nil. + (desc (and (not (string= desc "")) desc)) + (imagep (org-export-inline-image-p + link org-e-odt-inline-image-rules)) + (path (cond + ((member type '("http" "https" "ftp" "mailto")) + (concat type ":" raw-path)) + ((string= type "file") + (when (string-match "\\(.+\\)::.+" raw-path) + (setq raw-path (match-string 1 raw-path))) + (if (file-name-absolute-p raw-path) + (concat "file://" (expand-file-name raw-path)) + (concat "file://" raw-path))) + (t raw-path))) + protocol) + (cond + ;; Image file. + ((and (not desc) (org-export-inline-image-p + link org-e-odt-inline-image-rules)) + (org-e-odt-link--inline-image link info)) + ;; Radio target: Transcode target's contents and use them as + ;; link's description. + ((string= type "radio") + (let ((destination (org-export-resolve-radio-link link info))) + (when destination + (org-e-odt-format-internal-link + (org-export-data (org-element-contents destination) info) + (org-export-solidify-link-text path))))) + ;; Links pointing to an headline: Find destination and build + ;; appropriate referencing command. + ((member type '("custom-id" "fuzzy" "id")) + (let ((destination (if (string= type "fuzzy") + (org-export-resolve-fuzzy-link link info) + (org-export-resolve-id-link link info)))) + (case (org-element-type destination) + ;; Fuzzy link points nowhere. + ('nil + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "Emphasis" (or desc (org-export-data + (org-element-property + :raw-link link) info)))) + ;; Fuzzy link points to an invisible target. + (keyword nil) + ;; LINK points to an headline. Check if LINK should display + ;; section numbers. + (headline + (let* ((headline-no (org-export-get-headline-number destination info)) + (label (format "sec-%s" (mapconcat 'number-to-string + headline-no "-"))) + (desc + ;; Case 1: Headline is numbered and LINK has no + ;; description or LINK's description matches + ;; headline's title. Display section number. + (if (and (org-export-numbered-headline-p destination info) + (or (not desc) + (string= desc (org-element-property + :raw-value destination)))) + headline-no + ;; Case 2: Either the headline is un-numbered or + ;; LINK has a custom description. Display LINK's + ;; description or headline's title. + (or desc (org-export-data (org-element-property + :title destination) info))))) + (org-e-odt-format-internal-link desc label))) + ;; Fuzzy link points to a target. Do as above. + (otherwise + ;; (unless desc + ;; (setq number (cond + ;; ((org-e-odt-standalone-image-p destination info) + ;; (org-export-get-ordinal + ;; (assoc 'link (org-element-contents destination)) + ;; info 'link 'org-e-odt-standalone-image-p)) + ;; (t (org-export-get-ordinal destination info)))) + ;; (setq desc (when number + ;; (if (atom number) (number-to-string number) + ;; (mapconcat 'number-to-string number "."))))) + + (let ((label-reference + (org-e-odt-format-label destination info 'reference))) + (assert label-reference) + label-reference))))) + ;; Coderef: replace link with the reference name or the + ;; equivalent line number. + ((string= type "coderef") + (let* ((fmt (org-export-get-coderef-format path desc)) + (res (org-export-resolve-coderef path info)) + (href (concat "#coderef-" path))) + (format fmt (org-e-odt-format-link res href)))) + ;; Link type is handled by a special function. + ((functionp (setq protocol (nth 2 (assoc type org-link-protocols)))) + (funcall protocol (org-link-unescape path) desc 'odt)) + ;; External link with a description part. + ((and path desc) (org-e-odt-format-link desc path)) + ;; External link without a description part. + (path (org-e-odt-format-link path path)) + ;; No path, only description. Try to do something useful. + (t (format "<text:span text:style-name=\"%s\">%s</text:span>" + "Emphasis" desc))))) + + +;;;; Babel Call + +;; Babel Calls are ignored. + + +;;;; Macro + +(defun org-e-odt-macro (macro contents info) + "Transcode a MACRO element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + ;; Use available tools. + (org-export-expand-macro macro info)) + + +;;;; Paragraph + +(defun org-e-odt-paragraph (paragraph contents info) + "Transcode a PARAGRAPH element from Org to ODT. +CONTENTS is the contents of the paragraph, as a string. INFO is +the plist used as a communication channel." + (let* ((parent (org-export-get-parent paragraph)) + (parent-type (org-element-type parent)) + (style (case parent-type + (quote-block "Quotations") + (center-block "OrgCenter") + (footnote-definition "Footnote") + (t "Text_20_body")))) + ;; If this paragraph is a leading paragraph in a non-descriptive + ;; item and the item has a checkbox, splice the checkbox and + ;; paragraph contents together. + (when (and (eq (org-element-type parent) 'item) + (not (eq (org-element-property :type + (org-export-get-parent parent)) + 'descriptive)) + (eq paragraph (car (org-element-contents parent)))) + (setq contents (concat (org-e-odt--checkbox parent) contents))) + (assert style) + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" style contents))) + + +;;;; Plain List + +(defun org-e-odt-plain-list (plain-list contents info) + "Transcode a PLAIN-LIST element from Org to ODT. +CONTENTS is the contents of the list. INFO is a plist holding +contextual information." + (let* ((type (org-element-property :type plain-list)) + (continue-numbering nil)) + (assert (member type '(ordered unordered descriptive))) + (org-e-odt--wrap-label + plain-list + (format "\n<text:list text:style-name=\"%s\" %s>\n%s</text:list>" + (assoc-default type '((ordered . "OrgNumberedList") + (unordered . "OrgBulletedList") + (descriptive . "OrgDescriptionList"))) + ;; If top-level list, re-start numbering. Otherwise, + ;; continue numbering. + (format "text:continue-numbering=\"%s\"" + (let* ((parent (org-export-get-parent plain-list))) + (if (and parent (eq (org-element-type parent) 'item)) + "true" "false"))) + contents)))) + +;;;; Plain Text + +(defun org-e-odt-fill-tabs-and-spaces (line) + (replace-regexp-in-string + "\\([\t]\\|\\([ ]+\\)\\)" + (lambda (s) + (cond + ((string= s "\t") "<text:tab/>") + (t (let ((n (length s))) + (cond + ((= n 1) " ") + ((> n 1) (concat " " (format "<text:s text:c=\"%d\"/>" (1- n)))) + (t "")))))) + line)) + +(defun org-e-odt-encode-plain-text (text &optional no-whitespace-filling) + (mapc + (lambda (pair) + (setq text (replace-regexp-in-string (car pair) (cdr pair) text t t))) + '(("&" . "&") ("<" . "<") (">" . ">"))) + (if no-whitespace-filling text + (org-e-odt-fill-tabs-and-spaces text))) + +(defun org-e-odt--quotation-marks (text info) + "Export quotation marks depending on language conventions. +TEXT is a string containing quotation marks to be replaced. INFO +is a plist used as a communication channel." + (mapc (lambda(l) + (let ((start 0)) + (while (setq start (string-match (car l) text start)) + (let ((new-quote (concat (match-string 1 text) (cdr l)))) + (setq text (replace-match new-quote t t text)))))) + (cdr (or (assoc (plist-get info :language) org-e-odt-quotes) + ;; Falls back on English. + (assoc "en" org-e-odt-quotes)))) + text) + +(defun org-e-odt-plain-text (text info) + "Transcode a TEXT string from Org to ODT. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; Protect &, < and >. + (setq text (org-e-odt-encode-plain-text text t)) + ;; Handle quotation marks + (setq text (org-e-odt--quotation-marks text info)) + ;; Convert special strings. + (when (plist-get info :with-special-strings) + (mapc + (lambda (pair) + (setq text (replace-regexp-in-string (car pair) (cdr pair) text t nil))) + org-e-odt-special-string-regexps)) + ;; Handle break preservation if required. + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string + "\\(\\\\\\\\\\)?[ \t]*\n" "<text:line-break/>\n" text t))) + ;; Return value. + text) + + +;;;; Planning + +(defun org-e-odt-planning (planning contents info) + "Transcode a PLANNING element from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestampWrapper" + (concat + (let ((closed (org-element-property :closed planning))) + (when closed + (concat + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestampKeyword" org-closed-string) + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestamp" (org-translate-time closed))))) + (let ((deadline (org-element-property :deadline planning))) + (when deadline + (concat + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestampKeyword" org-deadline-string) + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestamp" (org-translate-time deadline))))) + (let ((scheduled (org-element-property :scheduled planning))) + (when scheduled + (concat + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestampKeyword" org-scheduled-string) + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestamp" (org-translate-time scheduled)))))))) + + +;;;; Property Drawer + +(defun org-e-odt-property-drawer (property-drawer contents info) + "Transcode a PROPERTY-DRAWER element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual +information." + ;; The property drawer isn't exported but we want separating blank + ;; lines nonetheless. + "") + + +;;;; Quote Block + +(defun org-e-odt-quote-block (quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to ODT. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (org-e-odt--wrap-label quote-block contents)) + + +;;;; Quote Section + +(defun org-e-odt-quote-section (quote-section contents info) + "Transcode a QUOTE-SECTION element from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((value (org-remove-indentation + (org-element-property :value quote-section)))) + (when value (org-e-odt-do-format-code value)))) + + +;;;; Section + + +(defun org-e-odt-format-section (text style &optional name) + (let ((default-name (car (org-e-odt-add-automatic-style "Section")))) + (format "\n<text:section text:style-name=\"%s\" %s>\n%s</text:section>" + style + (format "text:name=\"%s\"" (or name default-name)) + text))) + + +(defun org-e-odt-section (section contents info) ; FIXME + "Transcode a SECTION element from Org to ODT. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + contents) + +;;;; Radio Target + +(defun org-e-odt-radio-target (radio-target text info) + "Transcode a RADIO-TARGET object from Org to ODT. +TEXT is the text of the target. INFO is a plist holding +contextual information." + (org-e-odt-format-target + text (org-export-solidify-link-text + (org-element-property :value radio-target)))) + + +;;;; Special Block + +(defun org-e-odt-special-block (special-block contents info) + "Transcode a SPECIAL-BLOCK element from Org to ODT. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((type (downcase (org-element-property :type special-block))) + (attributes (org-export-read-attribute :attr_odt special-block))) + (org-e-odt--wrap-label + special-block + (cond + ;; Annotation. + ((string= type "annotation") + (let ((author (or (plist-get attributes :author) + (let ((author (plist-get info :author))) + (and author (org-export-data author info))))) + (date (or (plist-get attributes :date) + (plist-get info :date)))) + + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Text_20_body" + (format "<office:annotation>\n%s\n</office:annotation>" + (concat + (and author + (format "<dc:creator>%s</dc:creator>" author)) + (and date + (format "<dc:date>%s</dc:date>" + (org-e-odt--date date))) + contents))))) + ;; Textbox. + ((string= type "textbox") + (let ((width (plist-get attributes :width)) + (height (plist-get attributes :height)) + (style (plist-get attributes :style)) + (extra (plist-get attributes :extra)) + (anchor (plist-get attributes :anchor))) + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Text_20_body" (org-e-odt--textbox contents width height + style extra anchor)))) + (t contents))))) + + +;;;; Src Block + + +(defun org-e-odt-hfy-face-to-css (fn) + "Create custom style for face FN. +When FN is the default face, use it's foreground and background +properties to create \"OrgSrcBlock\" paragraph style. Otherwise +use it's color attribute to create a character style whose name +is obtained from FN. Currently all attributes of FN other than +color are ignored. + +The style name for a face FN is derived using the following +operations on the face name in that order - de-dash, CamelCase +and prefix with \"OrgSrc\". For example, +`font-lock-function-name-face' is associated with +\"OrgSrcFontLockFunctionNameFace\"." + (let* ((css-list (hfy-face-to-style fn)) + (style-name ((lambda (fn) + (concat "OrgSrc" + (mapconcat + 'capitalize (split-string + (hfy-face-or-def-to-name fn) "-") + ""))) fn)) + (color-val (cdr (assoc "color" css-list))) + (background-color-val (cdr (assoc "background" css-list))) + (style (and org-e-odt-create-custom-styles-for-srcblocks + (cond + ((eq fn 'default) + (format org-e-odt-src-block-paragraph-format + background-color-val color-val)) + (t + (format + " +<style:style style:name=\"%s\" style:family=\"text\"> + <style:text-properties fo:color=\"%s\"/> + </style:style>" style-name color-val)))))) + (cons style-name style))) + +(defun org-e-odt-htmlfontify-string (line) + (let* ((hfy-html-quote-regex "\\([<\"&> ]\\)") + (hfy-html-quote-map '(("\"" """) + ("<" "<") + ("&" "&") + (">" ">") + (" " "<text:s/>") + (" " "<text:tab/>"))) + (hfy-face-to-css 'org-e-odt-hfy-face-to-css) + (hfy-optimisations-1 (copy-seq hfy-optimisations)) + (hfy-optimisations (add-to-list 'hfy-optimisations-1 + 'body-text-only)) + (hfy-begin-span-handler + (lambda (style text-block text-id text-begins-block-p) + (insert (format "<text:span text:style-name=\"%s\">" style)))) + (hfy-end-span-handler (lambda nil (insert "</text:span>")))) + (with-no-warnings (htmlfontify-string line)))) + +(defun org-e-odt-do-format-code + (code &optional lang refs retain-labels num-start) + (let* ((lang (or (assoc-default lang org-src-lang-modes) lang)) + (lang-mode (and lang (intern (format "%s-mode" lang)))) + (code-lines (org-split-string code "\n")) + (code-length (length code-lines)) + (use-htmlfontify-p (and (functionp lang-mode) + org-e-odt-fontify-srcblocks + (require 'htmlfontify nil t) + (fboundp 'htmlfontify-string))) + (code (if (not use-htmlfontify-p) code + (with-temp-buffer + (insert code) + (funcall lang-mode) + (font-lock-fontify-buffer) + (buffer-string)))) + (fontifier (if use-htmlfontify-p 'org-e-odt-htmlfontify-string + 'org-e-odt-encode-plain-text)) + (par-style (if use-htmlfontify-p "OrgSrcBlock" + "OrgFixedWidthBlock")) + (i 0)) + (assert (= code-length (length (org-split-string code "\n")))) + (setq code + (org-export-format-code + code + (lambda (loc line-num ref) + (setq par-style + (concat par-style (and (= (incf i) code-length) "LastLine"))) + + (setq loc (concat loc (and ref retain-labels (format " (%s)" ref)))) + (setq loc (funcall fontifier loc)) + (when ref + (setq loc (org-e-odt-format-target loc (concat "coderef-" ref)))) + (assert par-style) + (setq loc (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + par-style loc)) + (if (not line-num) loc + (format "\n<text:list-item>%s\n</text:list-item>" loc))) + num-start refs)) + (cond + ((not num-start) code) + ((= num-start 0) + (format + "\n<text:list text:style-name=\"OrgSrcBlockNumberedLine\"%s>%s</text:list>" + " text:continue-numbering=\"false\"" code)) + (t + (format + "\n<text:list text:style-name=\"OrgSrcBlockNumberedLine\"%s>%s</text:list>" + " text:continue-numbering=\"true\"" code))))) + +(defun org-e-odt-format-code (element info) + (let* ((lang (org-element-property :language element)) + ;; Extract code and references. + (code-info (org-export-unravel-code element)) + (code (car code-info)) + (refs (cdr code-info)) + ;; Does the src block contain labels? + (retain-labels (org-element-property :retain-labels element)) + ;; Does it have line numbers? + (num-start (case (org-element-property :number-lines element) + (continued (org-export-get-loc element info)) + (new 0)))) + (org-e-odt-do-format-code code lang refs retain-labels num-start))) + +(defun org-e-odt-src-block (src-block contents info) + "Transcode a SRC-BLOCK element from Org to ODT. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((lang (org-element-property :language src-block)) + (caption (org-element-property :caption src-block)) + (short-caption (and (cdr caption) + (org-export-data (cdr caption) info))) + (caption (and (car caption) (org-export-data (car caption) info))) + (label (org-element-property :name src-block)) + (attributes (org-export-read-attribute :attr_odt src-block))) + ;; FIXME: Handle caption + ;; caption-str (when caption) + ;; (main (org-export-data (car caption) info)) + ;; (secondary (org-export-data (cdr caption) info)) + ;; (caption-str (org-e-odt--caption/label-string caption label info)) + (let* ((captions (org-e-odt-format-label src-block info 'definition)) + (caption (car captions)) (short-caption (cdr captions))) + (concat + (and caption + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Listing" caption)) + (let ((--src-block (org-e-odt-format-code src-block info))) + (if (not (plist-get attributes :textbox)) --src-block + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Text_20_body" + (org-e-odt--textbox --src-block nil nil nil)))))))) + + +;;;; Statistics Cookie + +(defun org-e-odt-statistics-cookie (statistics-cookie contents info) + "Transcode a STATISTICS-COOKIE object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((cookie-value (org-element-property :value statistics-cookie))) + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgCode" cookie-value))) + + +;;;; Strike-Through + +(defun org-e-odt-strike-through (strike-through contents info) + "Transcode STRIKE-THROUGH from Org to ODT. +CONTENTS is the text with strike-through markup. INFO is a plist +holding contextual information." + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "Strikethrough" contents)) + + +;;;; Subscript + +(defun org-e-odt-subscript (subscript contents info) + "Transcode a SUBSCRIPT object from Org to ODT. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgSubscript" contents)) + + +;;;; Superscript + +(defun org-e-odt-superscript (superscript contents info) + "Transcode a SUPERSCRIPT object from Org to ODT. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgSuperscript" contents)) + + +;;;; Table Cell + +(defun org-e-odt-table-style-spec (element info) + (let* ((table (org-export-get-parent-table element)) + (table-attributes (org-export-read-attribute :attr_odt table)) + (table-style (plist-get table-attributes :style))) + (assoc table-style org-e-odt-table-styles))) + +(defun org-e-odt-get-table-cell-styles (table-cell info) + "Retrieve styles applicable to a table cell. +R and C are (zero-based) row and column numbers of the table +cell. STYLE-SPEC is an entry in `org-e-odt-table-styles' +applicable to the current table. It is `nil' if the table is not +associated with any style attributes. + +Return a cons of (TABLE-CELL-STYLE-NAME . PARAGRAPH-STYLE-NAME). + +When STYLE-SPEC is nil, style the table cell the conventional way +- choose cell borders based on row and column groupings and +choose paragraph alignment based on `org-col-cookies' text +property. See also +`org-e-odt-get-paragraph-style-cookie-for-table-cell'. + +When STYLE-SPEC is non-nil, ignore the above cookie and return +styles congruent with the ODF-1.2 specification." + (let* ((table-cell-address (org-export-table-cell-address table-cell info)) + (r (car table-cell-address)) (c (cdr table-cell-address)) + (style-spec (org-e-odt-table-style-spec table-cell info)) + (table-dimensions (org-export-table-dimensions + (org-export-get-parent-table table-cell) + info))) + (when style-spec + ;; LibreOffice - particularly the Writer - honors neither table + ;; templates nor custom table-cell styles. Inorder to retain + ;; inter-operability with LibreOffice, only automatic styles are + ;; used for styling of table-cells. The current implementation is + ;; congruent with ODF-1.2 specification and hence is + ;; future-compatible. + + ;; Additional Note: LibreOffice's AutoFormat facility for tables - + ;; which recognizes as many as 16 different cell types - is much + ;; richer. Unfortunately it is NOT amenable to easy configuration + ;; by hand. + (let* ((template-name (nth 1 style-spec)) + (cell-style-selectors (nth 2 style-spec)) + (cell-type + (cond + ((and (cdr (assoc 'use-first-column-styles cell-style-selectors)) + (= c 0)) "FirstColumn") + ((and (cdr (assoc 'use-last-column-styles cell-style-selectors)) + (= (1+ c) (cdr table-dimensions))) + "LastColumn") + ((and (cdr (assoc 'use-first-row-styles cell-style-selectors)) + (= r 0)) "FirstRow") + ((and (cdr (assoc 'use-last-row-styles cell-style-selectors)) + (= (1+ r) (car table-dimensions))) + "LastRow") + ((and (cdr (assoc 'use-banding-rows-styles cell-style-selectors)) + (= (% r 2) 1)) "EvenRow") + ((and (cdr (assoc 'use-banding-rows-styles cell-style-selectors)) + (= (% r 2) 0)) "OddRow") + ((and (cdr (assoc 'use-banding-columns-styles cell-style-selectors)) + (= (% c 2) 1)) "EvenColumn") + ((and (cdr (assoc 'use-banding-columns-styles cell-style-selectors)) + (= (% c 2) 0)) "OddColumn") + (t "")))) + (concat template-name cell-type))))) + +(defun org-e-odt-table-cell (table-cell contents info) + "Transcode a TABLE-CELL element from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (let* ((table-cell-address (org-export-table-cell-address table-cell info)) + (r (car table-cell-address)) + (c (cdr table-cell-address)) + (horiz-span (or (org-export-table-cell-width table-cell info) 0)) + (table-row (org-export-get-parent table-cell)) + (custom-style-prefix (org-e-odt-get-table-cell-styles + table-cell info)) + (paragraph-style + (or + (and custom-style-prefix + (format "%sTableParagraph" custom-style-prefix)) + (concat + (cond + ((and (= 1 (org-export-table-row-group table-row info)) + (org-export-table-has-header-p + (org-export-get-parent-table table-row) info)) + "OrgTableHeading") + ((let* ((table (org-export-get-parent-table table-cell)) + (table-attrs (org-export-read-attribute :attr_odt table)) + (table-header-columns (plist-get table-attrs + :header-columns))) + (<= c (cond ((wholenump table-header-columns) + (- table-header-columns 1)) + (table-header-columns 0) + (t -1)))) + "OrgTableHeading") + (t "OrgTableContents")) + (capitalize (symbol-name (org-export-table-cell-alignment + table-cell info)))))) + (cell-style-name + (or + (and custom-style-prefix (format "%sTableCell" + custom-style-prefix)) + (concat + "OrgTblCell" + (when (or (org-export-table-row-starts-rowgroup-p table-row info) + (zerop r)) "T") + (when (org-export-table-row-ends-rowgroup-p table-row info) "B") + (when (and (org-export-table-cell-starts-colgroup-p table-cell info) + (not (zerop c)) ) "L")))) + (cell-attributes + (concat + (format " table:style-name=\"%s\"" cell-style-name) + (and (> horiz-span 0) + (format " table:number-columns-spanned=\"%d\"" + (1+ horiz-span)))))) + (unless contents (setq contents "")) + (concat + (assert paragraph-style) + (format "\n<table:table-cell%s>\n%s\n</table:table-cell>" + cell-attributes + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + paragraph-style contents)) + (let (s) + (dotimes (i horiz-span s) + (setq s (concat s "\n<table:covered-table-cell/>")))) + "\n"))) + + +;;;; Table Row + +(defun org-e-odt-table-row (table-row contents info) + "Transcode a TABLE-ROW element from Org to ODT. +CONTENTS is the contents of the row. INFO is a plist used as a +communication channel." + ;; Rules are ignored since table separators are deduced from + ;; borders of the current row. + (when (eq (org-element-property :type table-row) 'standard) + (let* ((rowgroup-tags + (if (and (= 1 (org-export-table-row-group table-row info)) + (org-export-table-has-header-p + (org-export-get-parent-table table-row) info)) + ;; If the row belongs to the first rowgroup and the + ;; table has more than one row groups, then this row + ;; belongs to the header row group. + '("\n<table:table-header-rows>" . "\n</table:table-header-rows>") + ;; Otherwise, it belongs to non-header row group. + '("\n<table:table-rows>" . "\n</table:table-rows>")))) + (concat + ;; Does this row begin a rowgroup? + (when (org-export-table-row-starts-rowgroup-p table-row info) + (car rowgroup-tags)) + ;; Actual table row + (format "\n<table:table-row>\n%s\n</table:table-row>" contents) + ;; Does this row end a rowgroup? + (when (org-export-table-row-ends-rowgroup-p table-row info) + (cdr rowgroup-tags)))))) + + +;;;; Table + +(defun org-e-odt-table-first-row-data-cells (table info) + (let ((table-row + (org-element-map + table 'table-row + (lambda (row) + (unless (eq (org-element-property :type row) 'rule) row)) + info 'first-match)) + (special-column-p (org-export-table-has-special-column-p table))) + (if (not special-column-p) (org-element-contents table-row) + (cdr (org-element-contents table-row))))) + +(defun org-e-odt--table (table contents info) + "Transcode a TABLE element from Org to ODT. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (case (org-element-property :type table) + ;; Case 1: table.el doesn't support export to OD format. Strip + ;; such tables from export. + (table.el + (prog1 nil + (message + (concat + "(org-e-odt): Found table.el-type table in the source Org file." + " table.el doesn't support export to ODT format." + " Stripping the table from export.")))) + ;; Case 2: Native Org tables. + (otherwise + (let* ((captions (org-e-odt-format-label table info 'definition)) + (caption (car captions)) (short-caption (cdr captions)) + (attributes (org-export-read-attribute :attr_odt table)) + (custom-table-style (nth 1 (org-e-odt-table-style-spec table info))) + (table-column-specs + (function + (lambda (table info) + (let* ((table-style (or custom-table-style "OrgTable")) + (column-style (format "%sColumn" table-style))) + (mapconcat + (lambda (table-cell) + (let ((width (1+ (or (org-export-table-cell-width + table-cell info) 0))) + (s (format + "\n<table:table-column table:style-name=\"%s\"/>" + column-style)) + out) + (dotimes (i width out) (setq out (concat s out))))) + (org-e-odt-table-first-row-data-cells table info) "\n")))))) + (concat + ;; caption. + (when caption + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "Table" caption)) + ;; begin table. + (let* ((automatic-name + (org-e-odt-add-automatic-style "Table" attributes))) + (format + "\n<table:table table:name=\"%s\" table:style-name=\"%s\">" + (or short-caption (car automatic-name)) + (or custom-table-style (cdr automatic-name) "OrgTable"))) + ;; column specification. + (funcall table-column-specs table info) + ;; actual contents. + "\n" contents + ;; end table. + "</table:table>"))))) + +(defun org-e-odt-table (table contents info) + "Transcode a TABLE element from Org to ODT. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (let* ((--get-previous-elements + (function + (lambda (blob info) + (let ((parent (org-export-get-parent blob))) + (cdr (member blob (reverse (org-element-contents parent)))))))) + (--element-preceded-by-table-p + (function + (lambda (element info) + (loop for el in (funcall --get-previous-elements element info) + thereis (eq (org-element-type el) 'table))))) + (--walk-list-genealogy-and-collect-tags + (function + (lambda (table info) + (let* ((genealogy (org-export-get-genealogy table)) + (list-genealogy + (when (eq (org-element-type (car genealogy)) 'item) + (loop for el in genealogy + when (member (org-element-type el) + '(item plain-list)) + collect el)))) + (loop for el in list-genealogy + with parent-list collect + (case (org-element-type el) + (plain-list + (setq parent-list el) + `("</text:list>" + . ,(let ((type (org-element-property :type el))) + (format + "<text:list text:style-name=\"%s\" %s>" + (assoc-default + type '((ordered . "OrgNumberedList") + (unordered . "OrgBulletedList") + (descriptive . "OrgDescriptionList"))) + "text:continue-numbering=\"true\"")))) + (item + (cond + ((not parent-list) + (if (funcall --element-preceded-by-table-p table info) + '("</text:list-header>" . "<text:list-header>") + '("</text:list-item>" . "<text:list-header>"))) + ((funcall --element-preceded-by-table-p + parent-list info) + '("</text:list-header>" . "<text:list-header>")) + (t '("</text:list-item>" . "<text:list-item>")))))))))) + (close-open-tags (funcall --walk-list-genealogy-and-collect-tags + table info))) + ;; OpenDocument schema does not permit table to occur within a + ;; list item. So, to typeset an indented table, we make use of + ;; list continuations. + (concat "\n" + ;; Discontinue the list. + (mapconcat 'car close-open-tags "\n") + ;; Put the table in an indented section. + (let* ((table (org-e-odt--table table contents info)) + (level (/ (length (mapcar 'car close-open-tags)) 2)) + (style (format "OrgIndentedSection-Level-%d" level))) + (when table (org-e-odt-format-section table style))) + ;; Continue the list. + (mapconcat 'cdr (nreverse close-open-tags) "\n")))) + + +;;;; Target + +(defun org-e-odt-target (target contents info) + "Transcode a TARGET object from Org to ODT. +CONTENTS is nil. INFO is a plist holding contextual +information." + (org-e-odt-format-target + "" (org-export-solidify-link-text (org-element-property :value target)))) + + +;;;; Timestamp + +(defun org-e-odt-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (let ((timestamp-1 (org-element-property :value timestamp)) + (timestamp-2 (org-element-property :range-end timestamp))) + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestampWrapper" + (concat + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestamp" (org-translate-time timestamp-1)) + (and timestamp-2 + "–" + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgTimestamp" (org-translate-time timestamp-2))))))) + + +;;;; Underline + +(defun org-e-odt-underline (underline contents info) + "Transcode UNDERLINE from Org to ODT. +CONTENTS is the text with underline markup. INFO is a plist +holding contextual information." + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "Underline" contents)) + + +;;;; Verbatim + +(defun org-e-odt-verbatim (verbatim contents info) + "Transcode a VERBATIM object from Org to ODT. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (format "<text:span text:style-name=\"%s\">%s</text:span>" + "OrgCode" (org-element-property :value verbatim))) + + +;;;; Verse Block + +(defun org-e-odt-verse-block (verse-block contents info) + "Transcode a VERSE-BLOCK element from Org to ODT. +CONTENTS is verse block contents. INFO is a plist holding +contextual information." + ;; Add line breaks to each line of verse. + (setq contents (replace-regexp-in-string + "\\(<text:line-break/>\\)?[ \t]*\n" + "<text:line-break/>" contents)) + ;; Replace tabs and spaces. + (setq contents (org-e-odt-fill-tabs-and-spaces contents)) + ;; Surround it in a verse environment. + (org-e-odt--wrap-label + verse-block + (format "\n<text:p text:style-name=\"%s\">%s</text:p>" + "OrgVerse" contents))) + + + + + +;;; Interactive functions + +(defun org-e-odt-create-manifest-file-entry (&rest args) + (push args org-e-odt-manifest-file-entries)) + +(defun org-e-odt-write-manifest-file () + (make-directory (concat org-e-odt-zip-dir "META-INF")) + (let ((manifest-file (concat org-e-odt-zip-dir "META-INF/manifest.xml"))) + (with-current-buffer + (let ((nxml-auto-insert-xml-declaration-flag nil)) + (find-file-noselect manifest-file t)) + (insert + "<?xml version=\"1.0\" encoding=\"UTF-8\"?> + <manifest:manifest xmlns:manifest=\"urn:oasis:names:tc:opendocument:xmlns:manifest:1.0\" manifest:version=\"1.2\">\n") + (mapc + (lambda (file-entry) + (let* ((version (nth 2 file-entry)) + (extra (if (not version) "" + (format " manifest:version=\"%s\"" version)))) + (insert + (format org-e-odt-manifest-file-entry-tag + (nth 0 file-entry) (nth 1 file-entry) extra)))) + org-e-odt-manifest-file-entries) + (insert "\n</manifest:manifest>")))) + +(defmacro org-e-odt--export-wrap (out-file &rest body) + `(let* ((--out-file ,out-file) + (out-file-type (file-name-extension --out-file)) + (org-e-odt-xml-files '("META-INF/manifest.xml" "content.xml" + "meta.xml" "styles.xml")) + ;; Initialize workarea. All files that end up in the + ;; exported get created here. + (org-e-odt-zip-dir (file-name-as-directory + (make-temp-file (format "%s-" out-file-type) t))) + (org-e-odt-manifest-file-entries nil) + (--cleanup-xml-buffers + (function + (lambda nil + ;; Kill all XML buffers. + (mapc (lambda (file) + (let ((buf (get-file-buffer + (concat org-e-odt-zip-dir file)))) + (when buf + (set-buffer-modified-p nil) + (kill-buffer buf)))) + org-e-odt-xml-files) + ;; Delete temporary directory and also other embedded + ;; files that get copied there. + (delete-directory org-e-odt-zip-dir t))))) + (org-condition-case-unless-debug + err + (progn + (unless (executable-find "zip") + ;; Not at all OSes ship with zip by default + (error "Executable \"zip\" needed for creating OpenDocument files")) + ;; Do export. This creates a bunch of xml files ready to be + ;; saved and zipped. + (progn ,@body) + ;; Create a manifest entry for content.xml. + (org-e-odt-create-manifest-file-entry "text/xml" "content.xml") + + ;; Write mimetype file + (let* ((mimetypes + '(("odt" . "application/vnd.oasis.opendocument.text") + ("odf" . "application/vnd.oasis.opendocument.formula"))) + (mimetype (cdr (assoc-string out-file-type mimetypes t)))) + (unless mimetype + (error "Unknown OpenDocument backend %S" out-file-type)) + (write-region mimetype nil (concat org-e-odt-zip-dir "mimetype")) + (org-e-odt-create-manifest-file-entry mimetype "/" "1.2")) + ;; Write out the manifest entries before zipping + (org-e-odt-write-manifest-file) + ;; Save all XML files. + (mapc (lambda (file) + (let ((buf (get-file-buffer (concat org-e-odt-zip-dir file)))) + (when buf + (with-current-buffer buf + ;; Prettify output if needed. + (when org-e-odt-prettify-xml + (indent-region (point-min) (point-max))) + (save-buffer 0))))) + org-e-odt-xml-files) + ;; Run zip. + (let* ((target --out-file) + (target-name (file-name-nondirectory target)) + (target-dir (file-name-directory target)) + (cmds `(("zip" "-mX0" ,target-name "mimetype") + ("zip" "-rmTq" ,target-name ".")))) + ;; If a file with same name as the desired output file + ;; exists, remove it. + (when (file-exists-p target) + (delete-file target)) + ;; Zip up the xml files. + (let ((coding-system-for-write 'no-conversion) exitcode err-string) + (message "Creating ODT file...") + ;; Switch temporarily to content.xml. This way Zip + ;; process will inherit `org-e-odt-zip-dir' as the current + ;; directory. + (with-current-buffer + (find-file-noselect (concat org-e-odt-zip-dir "content.xml") t) + (mapc + (lambda (cmd) + (message "Running %s" (mapconcat 'identity cmd " ")) + (setq err-string + (with-output-to-string + (setq exitcode + (apply 'call-process (car cmd) + nil standard-output nil (cdr cmd))))) + (or (zerop exitcode) + (error (concat "Unable to create OpenDocument file." + (format " Zip failed with error (%s)" + err-string))))) + cmds) + ;; Zip file is now in the rightful place. + (rename-file target-name target))) + (message "Created %s" target) + ;; Cleanup work directory and work files. + (funcall --cleanup-xml-buffers) + ;; Open the OpenDocument file in archive-mode for + ;; examination. + (find-file-noselect target t) + ;; Return exported file. + (cond + ;; Case 1: Conversion desired on exported file. Run the + ;; converter on the OpenDocument file. Return the + ;; converted file. + (org-e-odt-preferred-output-format + (or (org-e-odt-convert target org-e-odt-preferred-output-format) + target)) + ;; Case 2: No further conversion. Return exported + ;; OpenDocument file. + (t target)))) + ((quit error) + ;; Cleanup work directory and work files. + (funcall --cleanup-xml-buffers) + (message "OpenDocument export failed: %s" + (error-message-string err)))))) + + + +;;;###autoload +(defun org-e-odt-export-as-odf (latex-frag &optional odf-file) + "Export LATEX-FRAG as OpenDocument formula file ODF-FILE. +Use `org-create-math-formula' to convert LATEX-FRAG first to +MathML. When invoked as an interactive command, use +`org-latex-regexps' to infer LATEX-FRAG from currently active +region. If no LaTeX fragments are found, prompt for it. Push +MathML source to kill ring, if `org-export-copy-to-kill-ring' is +non-nil." + (interactive + `(,(let (frag) + (setq frag (and (setq frag (and (region-active-p) + (buffer-substring (region-beginning) + (region-end)))) + (loop for e in org-latex-regexps + thereis (when (string-match (nth 1 e) frag) + (match-string (nth 2 e) frag))))) + (read-string "LaTeX Fragment: " frag nil frag)) + ,(let ((odf-filename (expand-file-name + (concat + (file-name-sans-extension + (or (file-name-nondirectory buffer-file-name))) + "." "odf") + (file-name-directory buffer-file-name)))) + (read-file-name "ODF filename: " nil odf-filename nil + (file-name-nondirectory odf-filename))))) + (let ((filename (or odf-file + (expand-file-name + (concat + (file-name-sans-extension + (or (file-name-nondirectory buffer-file-name))) + "." "odf") + (file-name-directory buffer-file-name))))) + (org-e-odt--export-wrap + filename + (let* ((buffer (progn + (require 'nxml-mode) + (let ((nxml-auto-insert-xml-declaration-flag nil)) + (find-file-noselect (concat org-e-odt-zip-dir + "content.xml") t)))) + (coding-system-for-write 'utf-8) + (save-buffer-coding-system 'utf-8)) + (set-buffer buffer) + (set-buffer-file-coding-system coding-system-for-write) + (let ((mathml (org-create-math-formula latex-frag))) + (unless mathml (error "No Math formula created")) + (insert mathml) + ;; Add MathML to kill ring, if needed. + (when org-export-copy-to-kill-ring + (org-kill-new (buffer-string)))))))) + +;;;###autoload +(defun org-e-odt-export-as-odf-and-open () + "Export LaTeX fragment as OpenDocument formula and immediately open it. +Use `org-e-odt-export-as-odf' to read LaTeX fragment and OpenDocument +formula file." + (interactive) + (org-open-file (call-interactively 'org-e-odt-export-as-odf))) + +;;;###autoload +(defun org-e-odt-export-to-odt + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to a HTML file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (org-e-odt--export-wrap + (org-export-output-file-name ".odt" subtreep pub-dir) + (let* ((org-e-odt-embedded-images-count 0) + (org-e-odt-embedded-formulas-count 0) + (org-e-odt-automatic-styles nil) + (org-e-odt-object-counters nil) + ;; Let `htmlfontify' know that we are interested in collecting + ;; styles. + (hfy-user-sheet-assoc nil)) + ;; Initialize content.xml and kick-off the export process. + (let ((out-buf (progn + (require 'nxml-mode) + (let ((nxml-auto-insert-xml-declaration-flag nil)) + (find-file-noselect + (concat org-e-odt-zip-dir "content.xml") t))))) + (org-export-to-buffer 'e-odt out-buf subtreep visible-only body-only))))) + + + + +(defun org-e-odt-reachable-p (in-fmt out-fmt) + "Return non-nil if IN-FMT can be converted to OUT-FMT." + (catch 'done + (let ((reachable-formats (org-e-odt-do-reachable-formats in-fmt))) + (dolist (e reachable-formats) + (let ((out-fmt-spec (assoc out-fmt (cdr e)))) + (when out-fmt-spec + (throw 'done (cons (car e) out-fmt-spec)))))))) + +(defun org-e-odt-do-convert (in-file out-fmt &optional prefix-arg) + "Workhorse routine for `org-e-odt-convert'." + (require 'browse-url) + (let* ((in-file (expand-file-name (or in-file buffer-file-name))) + (dummy (or (file-readable-p in-file) + (error "Cannot read %s" in-file))) + (in-fmt (file-name-extension in-file)) + (out-fmt (or out-fmt (error "Output format unspecified"))) + (how (or (org-e-odt-reachable-p in-fmt out-fmt) + (error "Cannot convert from %s format to %s format?" + in-fmt out-fmt))) + (convert-process (car how)) + (out-file (concat (file-name-sans-extension in-file) "." + (nth 1 (or (cdr how) out-fmt)))) + (extra-options (or (nth 2 (cdr how)) "")) + (out-dir (file-name-directory in-file)) + (cmd (format-spec convert-process + `((?i . ,(shell-quote-argument in-file)) + (?I . ,(browse-url-file-url in-file)) + (?f . ,out-fmt) + (?o . ,out-file) + (?O . ,(browse-url-file-url out-file)) + (?d . , (shell-quote-argument out-dir)) + (?D . ,(browse-url-file-url out-dir)) + (?x . ,extra-options))))) + (when (file-exists-p out-file) + (delete-file out-file)) + + (message "Executing %s" cmd) + (let ((cmd-output (shell-command-to-string cmd))) + (message "%s" cmd-output)) + + (cond + ((file-exists-p out-file) + (message "Exported to %s" out-file) + (when prefix-arg + (message "Opening %s..." out-file) + (org-open-file out-file)) + out-file) + (t + (message "Export to %s failed" out-file) + nil)))) + +(defun org-e-odt-do-reachable-formats (in-fmt) + "Return verbose info about formats to which IN-FMT can be converted. +Return a list where each element is of the +form (CONVERTER-PROCESS . OUTPUT-FMT-ALIST). See +`org-e-odt-convert-processes' for CONVERTER-PROCESS and see +`org-e-odt-convert-capabilities' for OUTPUT-FMT-ALIST." + (let* ((converter + (and org-e-odt-convert-process + (cadr (assoc-string org-e-odt-convert-process + org-e-odt-convert-processes t)))) + (capabilities + (and org-e-odt-convert-process + (cadr (assoc-string org-e-odt-convert-process + org-e-odt-convert-processes t)) + org-e-odt-convert-capabilities)) + reachable-formats) + (when converter + (dolist (c capabilities) + (when (member in-fmt (nth 1 c)) + (push (cons converter (nth 2 c)) reachable-formats)))) + reachable-formats)) + +(defun org-e-odt-reachable-formats (in-fmt) + "Return list of formats to which IN-FMT can be converted. +The list of the form (OUTPUT-FMT-1 OUTPUT-FMT-2 ...)." + (let (l) + (mapc (lambda (e) (add-to-list 'l e)) + (apply 'append (mapcar + (lambda (e) (mapcar 'car (cdr e))) + (org-e-odt-do-reachable-formats in-fmt)))) + l)) + +(defun org-e-odt-convert-read-params () + "Return IN-FILE and OUT-FMT params for `org-e-odt-do-convert'. +This is a helper routine for interactive use." + (let* ((input (if (featurep 'ido) 'ido-completing-read 'completing-read)) + (in-file (read-file-name "File to be converted: " + nil buffer-file-name t)) + (in-fmt (file-name-extension in-file)) + (out-fmt-choices (org-e-odt-reachable-formats in-fmt)) + (out-fmt + (or (and out-fmt-choices + (funcall input "Output format: " + out-fmt-choices nil nil nil)) + (error + "No known converter or no known output formats for %s files" + in-fmt)))) + (list in-file out-fmt))) + +;;;###autoload +(defun org-e-odt-convert (&optional in-file out-fmt prefix-arg) + "Convert IN-FILE to format OUT-FMT using a command line converter. +IN-FILE is the file to be converted. If unspecified, it defaults +to variable `buffer-file-name'. OUT-FMT is the desired output +format. Use `org-e-odt-convert-process' as the converter. +If PREFIX-ARG is non-nil then the newly converted file is opened +using `org-open-file'." + (interactive + (append (org-e-odt-convert-read-params) current-prefix-arg)) + (org-e-odt-do-convert in-file out-fmt prefix-arg)) + +;;; Library Initializations + +(mapc + (lambda (desc) + ;; Let Org open all OpenDocument files using system-registered app + (add-to-list 'org-file-apps + (cons (concat "\\." (car desc) "\\'") 'system)) + ;; Let Emacs open all OpenDocument files in archive mode + (add-to-list 'auto-mode-alist + (cons (concat "\\." (car desc) "\\'") 'archive-mode))) + org-e-odt-file-extensions) + +(provide 'org-e-odt) + +;;; org-e-odt.el ends here diff --git a/contrib/lisp/org-e-publish.el b/contrib/lisp/org-e-publish.el new file mode 100644 index 0000000..894ee07 --- /dev/null +++ b/contrib/lisp/org-e-publish.el @@ -0,0 +1,1200 @@ +;;; org-e-publish.el --- publish related org-mode files as a website +;; Copyright (C) 2006-2012 Free Software Foundation, Inc. + +;; Author: David O'Toole <dto@gnu.org> +;; Maintainer: Carsten Dominik <carsten DOT dominik AT gmail DOT com> +;; Keywords: hypermedia, outlines, wp + +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This program allow configurable publishing of related sets of +;; Org mode files as a complete website. +;; +;; org-e-publish.el can do the following: +;; +;; + Publish all one's Org files to HTML or PDF +;; + Upload HTML, images, attachments and other files to a web server +;; + Exclude selected private pages from publishing +;; + Publish a clickable sitemap of pages +;; + Manage local timestamps for publishing only changed files +;; + Accept plugin functions to extend range of publishable content +;; +;; Documentation for publishing is in the manual. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'format-spec) +(require 'org-export) + +(declare-function org-e-latex-compile "org-e-latex" (texfile)) + + + +;;; Variables +(defvar org-e-publish-initial-buffer nil + "The buffer `org-e-publish' has been called from.") + +(defvar org-e-publish-temp-files nil + "Temporary list of files to be published.") + +;; Here, so you find the variable right before it's used the first time: +(defvar org-e-publish-cache nil + "This will cache timestamps and titles for files in publishing projects. +Blocks could hash sha1 values here.") + +(defgroup org-e-publish nil + "Options for publishing a set of Org-mode and related files." + :tag "Org Publishing" + :group 'org) + +(defcustom org-e-publish-project-alist nil + "Association list to control publishing behavior. +Each element of the alist is a publishing 'project.' The CAR of +each element is a string, uniquely identifying the project. The +CDR of each element is in one of the following forms: + +1. A well-formed property list with an even number of elements, + alternating keys and values, specifying parameters for the + publishing process. + + \(:property value :property value ... ) + +2. A meta-project definition, specifying of a list of + sub-projects: + + \(:components \(\"project-1\" \"project-2\" ...)) + +When the CDR of an element of org-e-publish-project-alist is in +this second form, the elements of the list after `:components' +are taken to be components of the project, which group together +files requiring different publishing options. When you publish +such a project with \\[org-e-publish], the components all +publish. + +When a property is given a value in +`org-e-publish-project-alist', its setting overrides the value of +the corresponding user variable \(if any) during publishing. +However, options set within a file override everything. + +Most properties are optional, but some should always be set: + + `:base-directory' + + Directory containing publishing source files. + + `:base-extension' + + Extension \(without the dot!) of source files. This can be + a regular expression. If not given, \"org\" will be used as + default extension. + + `:publishing-directory' + + Directory \(possibly remote) where output files will be + published. + +The `:exclude' property may be used to prevent certain files from +being published. Its value may be a string or regexp matching +file names you don't want to be published. + +The `:include' property may be used to include extra files. Its +value may be a list of filenames to include. The filenames are +considered relative to the base directory. + +When both `:include' and `:exclude' properties are given values, +the exclusion step happens first. + +One special property controls which back-end function to use for +publishing files in the project. This can be used to extend the +set of file types publishable by `org-e-publish', as well as the +set of output formats. + + `:publishing-function' + + Function to publish file. The default is + `org-e-publish-org-to-ascii', but other values are possible. + May also be a list of functions, in which case each function + in the list is invoked in turn. + +Another property allows you to insert code that prepares +a project for publishing. For example, you could call GNU Make +on a certain makefile, to ensure published files are built up to +date. + + `:preparation-function' + + Function to be called before publishing this project. This + may also be a list of functions. + + `:completion-function' + + Function to be called after publishing this project. This + may also be a list of functions. + +Some properties control details of the Org publishing process, +and are equivalent to the corresponding user variables listed in +the right column. Back-end specific properties may also be +included. See the back-end documentation for more information. + + :author `user-full-name' + :creator `org-export-creator-string' + :email `user-mail-address' + :exclude-tags `org-export-exclude-tags' + :headline-levels `org-export-headline-levels' + :language `org-export-default-language' + :preserve-breaks `org-export-preserve-breaks' + :section-numbers `org-export-with-section-numbers' + :select-tags `org-export-select-tags' + :time-stamp-file `org-export-time-stamp-file' + :with-archived-trees `org-export-with-archived-trees' + :with-author `org-export-with-author' + :with-creator `org-export-with-creator' + :with-drawers `org-export-with-drawers' + :with-email `org-export-with-email' + :with-emphasize `org-export-with-emphasize' + :with-entities `org-export-with-entities' + :with-fixed-width `org-export-with-fixed-width' + :with-footnotes `org-export-with-footnotes' + :with-priority `org-export-with-priority' + :with-special-strings `org-export-with-special-strings' + :with-sub-superscript `org-export-with-sub-superscripts' + :with-toc `org-export-with-toc' + :with-tables `org-export-with-tables' + :with-tags `org-export-with-tags' + :with-tasks `org-export-with-tasks' + :with-timestamps `org-export-with-timestamps' + :with-todo-keywords `org-export-with-todo-keywords' + +The following properties may be used to control publishing of +a site-map of files or summary page for a given project. + + `:auto-sitemap' + + Whether to publish a site-map during + `org-e-publish-current-project' or `org-e-publish-all'. + + `:sitemap-filename' + + Filename for output of sitemap. Defaults to \"sitemap.org\". + + `:sitemap-title' + + Title of site-map page. Defaults to name of file. + + `:sitemap-function' + + Plugin function to use for generation of site-map. Defaults to + `org-e-publish-org-sitemap', which generates a plain list of + links to all files in the project. + + `:sitemap-style' + + Can be `list' \(site-map is just an itemized list of the + titles of the files involved) or `tree' \(the directory + structure of the source files is reflected in the site-map). + Defaults to `tree'. + + `:sitemap-sans-extension' + + Remove extension from site-map's file-names. Useful to have + cool URIs \(see http://www.w3.org/Provider/Style/URI). + Defaults to nil. + +If you create a site-map file, adjust the sorting like this: + + `:sitemap-sort-folders' + + Where folders should appear in the site-map. Set this to + `first' \(default) or `last' to display folders first or + last, respectively. Any other value will mix files and + folders. + + `:sitemap-sort-files' + + The site map is normally sorted alphabetically. You can + change this behaviour setting this to `anti-chronologically', + `chronologically', or nil. + + `:sitemap-ignore-case' + + Should sorting be case-sensitive? Default nil. + +The following properties control the creation of a concept index. + + `:makeindex' + + Create a concept index. + +Other properties affecting publication. + + `:body-only' + + Set this to t to publish only the body of the documents." + :group 'org-e-publish + :type 'alist) + +(defcustom org-e-publish-use-timestamps-flag t + "Non-nil means use timestamp checking to publish only changed files. +When nil, do no timestamp checking and always publish all files." + :group 'org-e-publish + :type 'boolean) + +(defcustom org-e-publish-timestamp-directory + (convert-standard-filename "~/.org-timestamps/") + "Name of directory in which to store publishing timestamps." + :group 'org-e-publish + :type 'directory) + +(defcustom org-e-publish-list-skipped-files t + "Non-nil means show message about files *not* published." + :group 'org-e-publish + :type 'boolean) + +(defcustom org-e-publish-sitemap-sort-files 'alphabetically + "Method to sort files in site-maps. +Possible values are `alphabetically', `chronologically', +`anti-chronologically' and nil. + +If `alphabetically', files will be sorted alphabetically. If +`chronologically', files will be sorted with older modification +time first. If `anti-chronologically', files will be sorted with +newer modification time first. nil won't sort files. + +You can overwrite this default per project in your +`org-e-publish-project-alist', using `:sitemap-sort-files'." + :group 'org-e-publish + :type 'symbol) + +(defcustom org-e-publish-sitemap-sort-folders 'first + "A symbol, denoting if folders are sorted first in sitemaps. +Possible values are `first', `last', and nil. +If `first', folders will be sorted before files. +If `last', folders are sorted to the end after the files. +Any other value will not mix files and folders. + +You can overwrite this default per project in your +`org-e-publish-project-alist', using `:sitemap-sort-folders'." + :group 'org-e-publish + :type 'symbol) + +(defcustom org-e-publish-sitemap-sort-ignore-case nil + "Non-nil when site-map sorting should ignore case. + +You can overwrite this default per project in your +`org-e-publish-project-alist', using `:sitemap-ignore-case'." + :group 'org-e-publish + :type 'boolean) + +(defcustom org-e-publish-sitemap-date-format "%Y-%m-%d" + "Format for `format-time-string' which is used to print a date +in the sitemap." + :group 'org-e-publish + :type 'string) + +(defcustom org-e-publish-sitemap-file-entry-format "%t" + "Format string for site-map file entry. +You could use brackets to delimit on what part the link will be. + +%t is the title. +%a is the author. +%d is the date formatted using `org-e-publish-sitemap-date-format'." + :group 'org-e-publish + :type 'string) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Timestamp-related functions + +(defun org-e-publish-timestamp-filename (filename &optional pub-dir pub-func) + "Return path to timestamp file for filename FILENAME." + (setq filename (concat filename "::" (or pub-dir "") "::" + (format "%s" (or pub-func "")))) + (concat "X" (if (fboundp 'sha1) (sha1 filename) (md5 filename)))) + +(defun org-e-publish-needed-p + (filename &optional pub-dir pub-func true-pub-dir base-dir) + "Non-nil if FILENAME should be published in PUB-DIR using PUB-FUNC. +TRUE-PUB-DIR is where the file will truly end up. Currently we +are not using this - maybe it can eventually be used to check if +the file is present at the target location, and how old it is. +Right now we cannot do this, because we do not know under what +file name the file will be stored - the publishing function can +still decide about that independently." + (let ((rtn (if (not org-e-publish-use-timestamps-flag) t + (org-e-publish-cache-file-needs-publishing + filename pub-dir pub-func base-dir)))) + (if rtn (message "Publishing file %s using `%s'" filename pub-func) + (when org-e-publish-list-skipped-files + (message "Skipping unmodified file %s" filename))) + rtn)) + +(defun org-e-publish-update-timestamp + (filename &optional pub-dir pub-func base-dir) + "Update publishing timestamp for file FILENAME. +If there is no timestamp, create one." + (let ((key (org-e-publish-timestamp-filename filename pub-dir pub-func)) + (stamp (org-e-publish-cache-ctime-of-src filename base-dir))) + (org-e-publish-cache-set key stamp))) + +(defun org-e-publish-remove-all-timestamps () + "Remove all files in the timestamp directory." + (let ((dir org-e-publish-timestamp-directory) + files) + (when (and (file-exists-p dir) (file-directory-p dir)) + (mapc 'delete-file (directory-files dir 'full "[^.]\\'")) + (org-e-publish-reset-cache)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Getting project information out of `org-e-publish-project-alist' + +(defun org-e-publish-expand-projects (projects-alist) + "Expand projects in PROJECTS-ALIST. +This splices all the components into the list." + (let ((rest projects-alist) rtn p components) + (while (setq p (pop rest)) + (if (setq components (plist-get (cdr p) :components)) + (setq rest (append + (mapcar (lambda (x) (assoc x org-e-publish-project-alist)) + components) + rest)) + (push p rtn))) + (nreverse (delete-dups (delq nil rtn))))) + +(defvar org-sitemap-sort-files) +(defvar org-sitemap-sort-folders) +(defvar org-sitemap-ignore-case) +(defvar org-sitemap-requested) +(defvar org-sitemap-date-format) +(defvar org-sitemap-file-entry-format) +(defun org-e-publish-compare-directory-files (a b) + "Predicate for `sort', that sorts folders and files for sitemap." + (let ((retval t)) + (when (or org-sitemap-sort-files org-sitemap-sort-folders) + ;; First we sort files: + (when org-sitemap-sort-files + (case org-sitemap-sort-files + (alphabetically + (let* ((adir (file-directory-p a)) + (aorg (and (string-match "\\.org$" a) (not adir))) + (bdir (file-directory-p b)) + (borg (and (string-match "\\.org$" b) (not bdir))) + (A (if aorg (concat (file-name-directory a) + (org-e-publish-find-title a)) a)) + (B (if borg (concat (file-name-directory b) + (org-e-publish-find-title b)) b))) + (setq retval (if org-sitemap-ignore-case + (not (string-lessp (upcase B) (upcase A))) + (not (string-lessp B A)))))) + ((anti-chronologically chronologically) + (let* ((adate (org-e-publish-find-date a)) + (bdate (org-e-publish-find-date b)) + (A (+ (lsh (car adate) 16) (cadr adate))) + (B (+ (lsh (car bdate) 16) (cadr bdate)))) + (setq retval + (if (eq org-sitemap-sort-files 'chronologically) (<= A B) + (>= A B))))))) + ;; Directory-wise wins: + (when org-sitemap-sort-folders + ;; a is directory, b not: + (cond + ((and (file-directory-p a) (not (file-directory-p b))) + (setq retval (equal org-sitemap-sort-folders 'first))) + ;; a is not a directory, but b is: + ((and (not (file-directory-p a)) (file-directory-p b)) + (setq retval (equal org-sitemap-sort-folders 'last)))))) + retval)) + +(defun org-e-publish-get-base-files-1 + (base-dir &optional recurse match skip-file skip-dir) + "Set `org-e-publish-temp-files' with files from BASE-DIR directory. +If RECURSE is non-nil, check BASE-DIR recursively. If MATCH is +non-nil, restrict this list to the files matching the regexp +MATCH. If SKIP-FILE is non-nil, skip file matching the regexp +SKIP-FILE. If SKIP-DIR is non-nil, don't check directories +matching the regexp SKIP-DIR when recursing through BASE-DIR." + (mapc (lambda (f) + (let ((fd-p (file-directory-p f)) + (fnd (file-name-nondirectory f))) + (if (and fd-p recurse + (not (string-match "^\\.+$" fnd)) + (if skip-dir (not (string-match skip-dir fnd)) t)) + (org-e-publish-get-base-files-1 + f recurse match skip-file skip-dir) + (unless (or fd-p ;; this is a directory + (and skip-file (string-match skip-file fnd)) + (not (file-exists-p (file-truename f))) + (not (string-match match fnd))) + + (pushnew f org-e-publish-temp-files))))) + (if org-sitemap-requested + (sort (directory-files base-dir t (unless recurse match)) + 'org-e-publish-compare-directory-files) + (directory-files base-dir t (unless recurse match))))) + +(defun org-e-publish-get-base-files (project &optional exclude-regexp) + "Return a list of all files in PROJECT. +If EXCLUDE-REGEXP is set, this will be used to filter out +matching filenames." + (let* ((project-plist (cdr project)) + (base-dir (file-name-as-directory + (plist-get project-plist :base-directory))) + (include-list (plist-get project-plist :include)) + (recurse (plist-get project-plist :recursive)) + (extension (or (plist-get project-plist :base-extension) "org")) + ;; sitemap-... variables are dynamically scoped for + ;; org-e-publish-compare-directory-files: + (org-sitemap-requested + (plist-get project-plist :auto-sitemap)) + (sitemap-filename + (or (plist-get project-plist :sitemap-filename) "sitemap.org")) + (org-sitemap-sort-folders + (if (plist-member project-plist :sitemap-sort-folders) + (plist-get project-plist :sitemap-sort-folders) + org-e-publish-sitemap-sort-folders)) + (org-sitemap-sort-files + (cond ((plist-member project-plist :sitemap-sort-files) + (plist-get project-plist :sitemap-sort-files)) + ;; For backward compatibility: + ((plist-member project-plist :sitemap-alphabetically) + (if (plist-get project-plist :sitemap-alphabetically) + 'alphabetically nil)) + (t org-e-publish-sitemap-sort-files))) + (org-sitemap-ignore-case + (if (plist-member project-plist :sitemap-ignore-case) + (plist-get project-plist :sitemap-ignore-case) + org-e-publish-sitemap-sort-ignore-case)) + (match (if (eq extension 'any) "^[^\\.]" + (concat "^[^\\.].*\\.\\(" extension "\\)$")))) + ;; Make sure `org-sitemap-sort-folders' has an accepted value + (unless (memq org-sitemap-sort-folders '(first last)) + (setq org-sitemap-sort-folders nil)) + + (setq org-e-publish-temp-files nil) + (if org-sitemap-requested + (pushnew (expand-file-name (concat base-dir sitemap-filename)) + org-e-publish-temp-files)) + (org-e-publish-get-base-files-1 base-dir recurse match + ;; FIXME distinguish exclude regexp + ;; for skip-file and skip-dir? + exclude-regexp exclude-regexp) + (mapc (lambda (f) + (pushnew + (expand-file-name (concat base-dir f)) + org-e-publish-temp-files)) + include-list) + org-e-publish-temp-files)) + +(defun org-e-publish-get-project-from-filename (filename &optional up) + "Return the project that FILENAME belongs to." + (let* ((filename (expand-file-name filename)) + project-name) + + (catch 'p-found + (dolist (prj org-e-publish-project-alist) + (unless (plist-get (cdr prj) :components) + ;; [[info:org:Selecting%20files]] shows how this is supposed to work: + (let* ((r (plist-get (cdr prj) :recursive)) + (b (expand-file-name (file-name-as-directory + (plist-get (cdr prj) :base-directory)))) + (x (or (plist-get (cdr prj) :base-extension) "org")) + (e (plist-get (cdr prj) :exclude)) + (i (plist-get (cdr prj) :include)) + (xm (concat "^" b (if r ".+" "[^/]+") "\\.\\(" x "\\)$"))) + (when + (or (and i + (member filename + (mapcar (lambda (file) + (expand-file-name file b)) + i))) + (and (not (and e (string-match e filename))) + (string-match xm filename))) + (setq project-name (car prj)) + (throw 'p-found project-name)))))) + (when up + (dolist (prj org-e-publish-project-alist) + (if (member project-name (plist-get (cdr prj) :components)) + (setq project-name (car prj))))) + (assoc project-name org-e-publish-project-alist))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Pluggable publishing back-end functions + +(defun org-e-publish-org-to (backend filename extension plist pub-dir) + "Publish an Org file to a specified back-end. + +BACKEND is a symbol representing the back-end used for +transcoding. FILENAME is the filename of the Org file to be +published. EXTENSION is the extension used for the output +string, with the leading dot. PLIST is the property list for the +given project. PUB-DIR is the publishing directory. + +Return output file name." + (unless (file-exists-p pub-dir) (make-directory pub-dir t)) + ;; Check if a buffer visiting FILENAME is already open. + (let* ((visitingp (find-buffer-visiting filename)) + (work-buffer (or visitingp (find-file-noselect filename)))) + (prog1 (with-current-buffer work-buffer + (let ((output-file + (org-export-output-file-name extension nil pub-dir)) + (body-p (plist-get plist :body-only))) + (org-export-to-file + backend output-file nil nil body-p + ;; Install `org-e-publish-collect-index' in parse tree + ;; filters. It isn't dependent on `:makeindex', since + ;; we want to keep it up-to-date in cache anyway. + (org-combine-plists + plist `(:filter-parse-tree + (org-e-publish-collect-index + ,@(plist-get plist :filter-parse-tree))))))) + ;; Remove opened buffer in the process. + (unless visitingp (kill-buffer work-buffer))))) + +(defvar project-plist) +(defun org-e-publish-org-to-latex (plist filename pub-dir) + "Publish an Org file to LaTeX. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-publish-org-to 'e-latex filename ".tex" plist pub-dir)) + +(defun org-e-publish-org-to-pdf (plist filename pub-dir) + "Publish an Org file to PDF \(via LaTeX). + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-latex-compile + (org-e-publish-org-to 'e-latex filename ".tex" plist pub-dir))) + +(defun org-e-publish-org-to-html (plist filename pub-dir) + "Publish an org file to HTML. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-publish-org-to 'e-html filename ".html" plist pub-dir)) + +;; TODO: Not implemented yet. +;; (defun org-e-publish-org-to-org (plist filename pub-dir) +;; "Publish an org file to HTML. +;; +;; FILENAME is the filename of the Org file to be published. PLIST +;; is the property list for the given project. PUB-DIR is the +;; publishing directory. +;; +;; Return output file name." +;; (org-e-publish-org-to "org" plist filename pub-dir)) + +(defun org-e-publish-org-to-ascii (plist filename pub-dir) + "Publish an Org file to ASCII. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-publish-org-to + 'e-ascii filename ".txt" `(:ascii-charset ascii ,@plist) pub-dir)) + +(defun org-e-publish-org-to-latin1 (plist filename pub-dir) + "Publish an Org file to Latin-1. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-publish-org-to + 'e-ascii filename ".txt" `(:ascii-charset latin1 ,@plist) pub-dir)) + +(defun org-e-publish-org-to-utf8 (plist filename pub-dir) + "Publish an org file to UTF-8. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (org-e-publish-org-to + 'e-ascii filename ".txt" `(:ascii-charset utf-8 ,@plist) pub-dir)) + +(defun org-e-publish-attachment (plist filename pub-dir) + "Publish a file with no transformation of any kind. + +FILENAME is the filename of the Org file to be published. PLIST +is the property list for the given project. PUB-DIR is the +publishing directory. + +Return output file name." + (unless (file-directory-p pub-dir) + (make-directory pub-dir t)) + (or (equal (expand-file-name (file-name-directory filename)) + (file-name-as-directory (expand-file-name pub-dir))) + (copy-file filename + (expand-file-name (file-name-nondirectory filename) pub-dir) + t))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Publishing files, sets of files, and indices + +(defun org-e-publish-file (filename &optional project no-cache) + "Publish file FILENAME from PROJECT. +If NO-CACHE is not nil, do not initialize org-e-publish-cache and +write it to disk. This is needed, since this function is used to +publish single files, when entire projects are published. +See `org-e-publish-projects'." + (let* ((project + (or project + (or (org-e-publish-get-project-from-filename filename) + (error "File %s not part of any known project" + (abbreviate-file-name filename))))) + (project-plist (cdr project)) + (ftname (expand-file-name filename)) + (publishing-function + (or (plist-get project-plist :publishing-function) + 'org-e-publish-org-to-ascii)) + (base-dir + (file-name-as-directory + (expand-file-name + (or (plist-get project-plist :base-directory) + (error "Project %s does not have :base-directory defined" + (car project)))))) + (pub-dir + (file-name-as-directory + (file-truename + (or (eval (plist-get project-plist :publishing-directory)) + (error "Project %s does not have :publishing-directory defined" + (car project)))))) + tmp-pub-dir) + + (unless no-cache (org-e-publish-initialize-cache (car project))) + + (setq tmp-pub-dir + (file-name-directory + (concat pub-dir + (and (string-match (regexp-quote base-dir) ftname) + (substring ftname (match-end 0)))))) + (if (listp publishing-function) + ;; allow chain of publishing functions + (mapc (lambda (f) + (when (org-e-publish-needed-p + filename pub-dir f tmp-pub-dir base-dir) + (funcall f project-plist filename tmp-pub-dir) + (org-e-publish-update-timestamp filename pub-dir f base-dir))) + publishing-function) + (when (org-e-publish-needed-p + filename pub-dir publishing-function tmp-pub-dir base-dir) + (funcall publishing-function project-plist filename tmp-pub-dir) + (org-e-publish-update-timestamp + filename pub-dir publishing-function base-dir))) + (unless no-cache (org-e-publish-write-cache-file)))) + +(defun org-e-publish-projects (projects) + "Publish all files belonging to the PROJECTS alist. +If `:auto-sitemap' is set, publish the sitemap too. If +`:makeindex' is set, also produce a file theindex.org." + (mapc + (lambda (project) + ;; Each project uses its own cache file: + (org-e-publish-initialize-cache (car project)) + (let* ((project-plist (cdr project)) + (exclude-regexp (plist-get project-plist :exclude)) + (sitemap-p (plist-get project-plist :auto-sitemap)) + (sitemap-filename (or (plist-get project-plist :sitemap-filename) + "sitemap.org")) + (sitemap-function (or (plist-get project-plist :sitemap-function) + 'org-e-publish-org-sitemap)) + (org-sitemap-date-format + (or (plist-get project-plist :sitemap-date-format) + org-e-publish-sitemap-date-format)) + (org-sitemap-file-entry-format + (or (plist-get project-plist :sitemap-file-entry-format) + org-e-publish-sitemap-file-entry-format)) + (preparation-function + (plist-get project-plist :preparation-function)) + (completion-function (plist-get project-plist :completion-function)) + (files (org-e-publish-get-base-files project exclude-regexp)) file) + (when preparation-function (run-hooks 'preparation-function)) + (if sitemap-p (funcall sitemap-function project sitemap-filename)) + (dolist (file files) (org-e-publish-file file project t)) + (when (plist-get project-plist :makeindex) + (org-e-publish-index-generate-theindex + project (plist-get project-plist :base-directory)) + (org-e-publish-file + (expand-file-name + "theindex.org" (plist-get project-plist :base-directory)) + project t)) + (when completion-function (run-hooks 'completion-function)) + (org-e-publish-write-cache-file))) + (org-e-publish-expand-projects projects))) + +(defun org-e-publish-org-sitemap (project &optional sitemap-filename) + "Create a sitemap of pages in set defined by PROJECT. +Optionally set the filename of the sitemap with SITEMAP-FILENAME. +Default for SITEMAP-FILENAME is 'sitemap.org'." + (let* ((project-plist (cdr project)) + (dir (file-name-as-directory + (plist-get project-plist :base-directory))) + (localdir (file-name-directory dir)) + (indent-str (make-string 2 ?\ )) + (exclude-regexp (plist-get project-plist :exclude)) + (files (nreverse + (org-e-publish-get-base-files project exclude-regexp))) + (sitemap-filename (concat dir (or sitemap-filename "sitemap.org"))) + (sitemap-title (or (plist-get project-plist :sitemap-title) + (concat "Sitemap for project " (car project)))) + (sitemap-style (or (plist-get project-plist :sitemap-style) + 'tree)) + (sitemap-sans-extension + (plist-get project-plist :sitemap-sans-extension)) + (visiting (find-buffer-visiting sitemap-filename)) + (ifn (file-name-nondirectory sitemap-filename)) + file sitemap-buffer) + (with-current-buffer (setq sitemap-buffer + (or visiting (find-file sitemap-filename))) + (erase-buffer) + (insert (concat "#+TITLE: " sitemap-title "\n\n")) + (while (setq file (pop files)) + (let ((fn (file-name-nondirectory file)) + (link (file-relative-name file dir)) + (oldlocal localdir)) + (when sitemap-sans-extension + (setq link (file-name-sans-extension link))) + ;; sitemap shouldn't list itself + (unless (equal (file-truename sitemap-filename) + (file-truename file)) + (if (eq sitemap-style 'list) + (message "Generating list-style sitemap for %s" sitemap-title) + (message "Generating tree-style sitemap for %s" sitemap-title) + (setq localdir (concat (file-name-as-directory dir) + (file-name-directory link))) + (unless (string= localdir oldlocal) + (if (string= localdir dir) + (setq indent-str (make-string 2 ?\ )) + (let ((subdirs + (split-string + (directory-file-name + (file-name-directory + (file-relative-name localdir dir))) "/")) + (subdir "") + (old-subdirs (split-string + (file-relative-name oldlocal dir) "/"))) + (setq indent-str (make-string 2 ?\ )) + (while (string= (car old-subdirs) (car subdirs)) + (setq indent-str (concat indent-str (make-string 2 ?\ ))) + (pop old-subdirs) + (pop subdirs)) + (dolist (d subdirs) + (setq subdir (concat subdir d "/")) + (insert (concat indent-str " + " d "\n")) + (setq indent-str (make-string + (+ (length indent-str) 2) ?\ ))))))) + ;; This is common to 'flat and 'tree + (let ((entry + (org-e-publish-format-file-entry + org-sitemap-file-entry-format file project-plist)) + (regexp "\\(.*\\)\\[\\([^][]+\\)\\]\\(.*\\)")) + (cond ((string-match-p regexp entry) + (string-match regexp entry) + (insert (concat indent-str " + " (match-string 1 entry) + "[[file:" link "][" + (match-string 2 entry) + "]]" (match-string 3 entry) "\n"))) + (t + (insert (concat indent-str " + [[file:" link "][" + entry + "]]\n")))))))) + (save-buffer)) + (or visiting (kill-buffer sitemap-buffer)))) + +(defun org-e-publish-format-file-entry (fmt file project-plist) + (format-spec fmt + `((?t . ,(org-e-publish-find-title file t)) + (?d . ,(format-time-string org-sitemap-date-format + (org-e-publish-find-date file))) + (?a . ,(or (plist-get project-plist :author) user-full-name))))) + +(defun org-e-publish-find-title (file &optional reset) + "Find the title of FILE in project." + (or + (and (not reset) (org-e-publish-cache-get-file-property file :title nil t)) + (let* ((visiting (find-buffer-visiting file)) + (buffer (or visiting (find-file-noselect file))) + title) + (with-current-buffer buffer + (org-mode) + (setq title + (or (plist-get (org-export-get-environment) :title) + (file-name-nondirectory (file-name-sans-extension file))))) + (unless visiting (kill-buffer buffer)) + (org-e-publish-cache-set-file-property file :title title) + title))) + +(defun org-e-publish-find-date (file) + "Find the date of FILE in project. +If FILE provides a #+date keyword use it else use the file +system's modification time. + +It returns time in `current-time' format." + (let* ((visiting (find-buffer-visiting file)) + (file-buf (or visiting (find-file-noselect file nil))) + (date (plist-get + (with-current-buffer file-buf + (org-mode) + (org-export--get-inbuffer-options)) + :date))) + (unless visiting (kill-buffer file-buf)) + (if date (org-time-string-to-time date) + (when (file-exists-p file) + (nth 5 (file-attributes file)))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Interactive publishing functions + +;;;###autoload +(defalias 'org-e-publish-project 'org-e-publish) + +;;;###autoload +(defun org-e-publish (project &optional force) + "Publish PROJECT." + (interactive + (list + (assoc (org-icompleting-read + "Publish project: " + org-e-publish-project-alist nil t) + org-e-publish-project-alist) + current-prefix-arg)) + (setq org-e-publish-initial-buffer (current-buffer)) + (save-window-excursion + (let* ((org-e-publish-use-timestamps-flag + (if force nil org-e-publish-use-timestamps-flag))) + (org-e-publish-projects + (if (stringp project) + ;; If this function is called in batch mode, project is + ;; still a string here. + (list (assoc project org-e-publish-project-alist)) + (list project)))))) + +;;;###autoload +(defun org-e-publish-all (&optional force) + "Publish all projects. +With prefix argument, remove all files in the timestamp +directory and force publishing all files." + (interactive "P") + (when force (org-e-publish-remove-all-timestamps)) + (save-window-excursion + (let ((org-e-publish-use-timestamps-flag + (if force nil org-e-publish-use-timestamps-flag))) + (org-e-publish-projects org-e-publish-project-alist)))) + + +;;;###autoload +(defun org-e-publish-current-file (&optional force) + "Publish the current file. +With prefix argument, force publish the file." + (interactive "P") + (save-window-excursion + (let ((org-e-publish-use-timestamps-flag + (if force nil org-e-publish-use-timestamps-flag))) + (org-e-publish-file (buffer-file-name (buffer-base-buffer)))))) + +;;;###autoload +(defun org-e-publish-current-project (&optional force) + "Publish the project associated with the current file. +With a prefix argument, force publishing of all files in +the project." + (interactive "P") + (save-window-excursion + (let ((project (org-e-publish-get-project-from-filename + (buffer-file-name (buffer-base-buffer)) 'up)) + (org-e-publish-use-timestamps-flag + (if force nil org-e-publish-use-timestamps-flag))) + (if project (org-e-publish project) + (error "File %s is not part of any known project" + (buffer-file-name (buffer-base-buffer))))))) + + + +;;; Index generation + +(defun org-e-publish-collect-index (tree backend info) + "Update index for a file with TREE in cache. + +BACKEND is the back-end being used for transcoding. INFO is +a plist containing publishing options. + +The index relative to current file is stored as an alist. An +association has the following shape: \(TERM FILE-NAME PARENT), +where TERM is the indexed term, as a string, FILE-NAME is the +original full path of the file where the term in encountered, and +PARENT is the headline element containing the original index +keyword." + (org-e-publish-cache-set-file-property + (plist-get info :input-file) :index + (delete-dups + (org-element-map + tree 'keyword + (lambda (k) + (when (string= (downcase (org-element-property :key k)) + "index") + (let ((index (org-element-property :value k)) + (parent (org-export-get-parent-headline k))) + (list index (plist-get info :input-file) parent)))) + info))) + ;; Return parse-tree to avoid altering output. + tree) + +(defun org-e-publish-index-generate-theindex (project directory) + "Retrieve full index from cache and build \"theindex.org\". +PROJECT is the project the index relates to. DIRECTORY is the +publishing directory." + (let ((all-files (org-e-publish-get-base-files + project (plist-get (cdr project) :exclude))) + full-index) + ;; Compile full index. + (mapc + (lambda (file) + (let ((index (org-e-publish-cache-get-file-property file :index))) + (dolist (term index) + (unless (member term full-index) (push term full-index))))) + all-files) + ;; Sort it alphabetically. + (setq full-index + (sort full-index (lambda (a b) (string< (downcase (car a)) + (downcase (car b)))))) + ;; Fill "theindex.org". + (with-temp-buffer + (insert "#+TITLE: Index\n#+OPTIONS: num:nil author:nil\n") + (let ((current-letter nil) (last-entry nil)) + (dolist (idx full-index) + (let* ((entry (org-split-string (car idx) "!")) + (letter (upcase (substring (car entry) 0 1))) + ;; Transform file into a path relative to publishing + ;; directory. + (file (file-relative-name + (nth 1 idx) + (plist-get (cdr project) :base-directory)))) + ;; Check if another letter has to be inserted. + (unless (string= letter current-letter) + (insert (format "* %s\n" letter))) + ;; Compute the first difference between last entry and + ;; current one: it tells the level at which new items + ;; should be added. + (let* ((rank (loop for n from 0 to (length entry) + unless (equal (nth n entry) (nth n last-entry)) + return n)) + (len (length (nthcdr rank entry)))) + ;; For each term after the first difference, create + ;; a new sub-list with the term as body. Moreover, + ;; linkify the last term. + (dotimes (n len) + (insert + (concat + (make-string (* (+ rank n) 2) ? ) " - " + (if (not (= (1- len) n)) (nth (+ rank n) entry) + ;; Last term: Link it to TARGET, if possible. + (let ((target (nth 2 idx))) + (format + "[[%s][%s]]" + ;; Destination. + (cond + ((not target) (format "file:%s" file)) + ((let ((id (org-element-property :id target))) + (and id (format "id:%s" id)))) + ((let ((id (org-element-property :custom-id target))) + (and id (format "file:%s::#%s" file id)))) + (t (format "file:%s::*%s" file + (org-element-property :raw-value target)))) + ;; Description. + (car (last entry))))) + "\n")))) + (setq current-letter letter last-entry entry)))) + ;; Write index. + (write-file (expand-file-name "theindex.org" directory))))) + + + +;;; Caching functions + +(defun org-e-publish-write-cache-file (&optional free-cache) + "Write `org-e-publish-cache' to file. +If FREE-CACHE, empty the cache." + (unless org-e-publish-cache + (error "`org-e-publish-write-cache-file' called, but no cache present")) + + (let ((cache-file (org-e-publish-cache-get ":cache-file:"))) + (unless cache-file + (error "Cannot find cache-file name in `org-e-publish-write-cache-file'")) + (with-temp-file cache-file + (let (print-level print-length) + (insert "(setq org-e-publish-cache (make-hash-table :test 'equal :weakness nil :size 100))\n") + (maphash (lambda (k v) + (insert + (format (concat "(puthash %S " + (if (or (listp v) (symbolp v)) + "'" "") + "%S org-e-publish-cache)\n") k v))) + org-e-publish-cache))) + (when free-cache (org-e-publish-reset-cache)))) + +(defun org-e-publish-initialize-cache (project-name) + "Initialize the projects cache if not initialized yet and return it." + + (unless project-name + (error "Cannot initialize `org-e-publish-cache' without projects name in `org-e-publish-initialize-cache'")) + + (unless (file-exists-p org-e-publish-timestamp-directory) + (make-directory org-e-publish-timestamp-directory t)) + (unless (file-directory-p org-e-publish-timestamp-directory) + (error "Org publish timestamp: %s is not a directory" + org-e-publish-timestamp-directory)) + + (unless (and org-e-publish-cache + (string= (org-e-publish-cache-get ":project:") project-name)) + (let* ((cache-file + (concat + (expand-file-name org-e-publish-timestamp-directory) + project-name ".cache")) + (cexists (file-exists-p cache-file))) + + (when org-e-publish-cache (org-e-publish-reset-cache)) + + (if cexists (load-file cache-file) + (setq org-e-publish-cache + (make-hash-table :test 'equal :weakness nil :size 100)) + (org-e-publish-cache-set ":project:" project-name) + (org-e-publish-cache-set ":cache-file:" cache-file)) + (unless cexists (org-e-publish-write-cache-file nil)))) + org-e-publish-cache) + +(defun org-e-publish-reset-cache () + "Empty org-e-publish-cache and reset it nil." + (message "%s" "Resetting org-e-publish-cache") + (when (hash-table-p org-e-publish-cache) + (clrhash org-e-publish-cache)) + (setq org-e-publish-cache nil)) + +(defun org-e-publish-cache-file-needs-publishing + (filename &optional pub-dir pub-func base-dir) + "Check the timestamp of the last publishing of FILENAME. +Non-nil if the file needs publishing. The function also checks +if any included files have been more recently published, so that +the file including them will be republished as well." + (unless org-e-publish-cache + (error + "`org-e-publish-cache-file-needs-publishing' called, but no cache present")) + (let* ((case-fold-search t) + (key (org-e-publish-timestamp-filename filename pub-dir pub-func)) + (pstamp (org-e-publish-cache-get key)) + (visiting (find-buffer-visiting filename)) + included-files-ctime buf) + + (when (equal (file-name-extension filename) "org") + (setq buf (find-file (expand-file-name filename))) + (with-current-buffer buf + (goto-char (point-min)) + (while (re-search-forward + "^#\\+INCLUDE:[ \t]+\"\\([^\t\n\r\"]*\\)\"[ \t]*.*$" nil t) + (let* ((included-file (expand-file-name (match-string 1)))) + (add-to-list + 'included-files-ctime + (org-e-publish-cache-ctime-of-src included-file base-dir) + t)))) + ;; FIXME: don't kill current buffer. + (unless visiting (kill-buffer buf))) + (if (null pstamp) t + (let ((ctime (org-e-publish-cache-ctime-of-src filename base-dir))) + (or (< pstamp ctime) + (when included-files-ctime + (not (null (delq nil (mapcar (lambda(ct) (< ctime ct)) + included-files-ctime)))))))))) + +(defun org-e-publish-cache-set-file-property + (filename property value &optional project-name) + "Set the VALUE for a PROPERTY of file FILENAME in publishing cache to VALUE. +Use cache file of PROJECT-NAME. If the entry does not exist, it +will be created. Return VALUE." + ;; Evtl. load the requested cache file: + (if project-name (org-e-publish-initialize-cache project-name)) + (let ((pl (org-e-publish-cache-get filename))) + (if pl (progn (plist-put pl property value) value) + (org-e-publish-cache-get-file-property + filename property value nil project-name)))) + +(defun org-e-publish-cache-get-file-property + (filename property &optional default no-create project-name) + "Return the value for a PROPERTY of file FILENAME in publishing cache. +Use cache file of PROJECT-NAME. Return the value of that PROPERTY +or DEFAULT, if the value does not yet exist. If the entry will +be created, unless NO-CREATE is not nil." + ;; Evtl. load the requested cache file: + (if project-name (org-e-publish-initialize-cache project-name)) + (let ((pl (org-e-publish-cache-get filename)) retval) + (if pl + (if (plist-member pl property) + (setq retval (plist-get pl property)) + (setq retval default)) + ;; no pl yet: + (unless no-create + (org-e-publish-cache-set filename (list property default))) + (setq retval default)) + retval)) + +(defun org-e-publish-cache-get (key) + "Return the value stored in `org-e-publish-cache' for key KEY. +Returns nil, if no value or nil is found, or the cache does not +exist." + (unless org-e-publish-cache + (error "`org-e-publish-cache-get' called, but no cache present")) + (gethash key org-e-publish-cache)) + +(defun org-e-publish-cache-set (key value) + "Store KEY VALUE pair in `org-e-publish-cache'. +Returns value on success, else nil." + (unless org-e-publish-cache + (error "`org-e-publish-cache-set' called, but no cache present")) + (puthash key value org-e-publish-cache)) + +(defun org-e-publish-cache-ctime-of-src (f base-dir) + "Get the FILENAME ctime as an integer." + (let ((attr (file-attributes + (expand-file-name (or (file-symlink-p f) f) base-dir)))) + (+ (lsh (car (nth 5 attr)) 16) + (cadr (nth 5 attr))))) + + +(provide 'org-e-publish) + +;;; org-e-publish.el ends here diff --git a/contrib/lisp/org-e-texinfo.el b/contrib/lisp/org-e-texinfo.el new file mode 100644 index 0000000..a19139f --- /dev/null +++ b/contrib/lisp/org-e-texinfo.el @@ -0,0 +1,1844 @@ +;;; org-e-texinfo.el --- Texinfo Back-End For Org Export Engine + +;; Copyright (C) 2012 Jonathan Leech-Pepin +;; Author: Jonathan Leech-Pepin <jonathan.leechpepin at gmail dot com> +;; Keywords: outlines, hypermedia, calendar, wp +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; This library implements a Texinfo back-end for Org generic +;; exporter. +;; +;; To test it, run +;; +;; M-: (org-export-to-buffer 'e-texinfo "*Test e-texinfo*") RET +;; +;; in an org-mode buffer then switch to the buffer to see the Texinfo +;; export. See contrib/lisp/org-export.el for more details on how +;; this exporter works. +;; +;; It introduces eight new buffer keywords: "TEXINFO_CLASS", +;; "TEXINFO_FILENAME", "TEXINFO_HEADER", "TEXINFO_DIR_CATEGORY", +;; "TEXINFO_DIR_TITLE", "TEXINFO_DIR_DESC" "SUBTITLE" and "SUBAUTHOR". +;; +;; To include inline code snippets (for example for generating @kbd{} +;; and @key{} commands), the following export-snippet keys are +;; accepted: +;; +;; info +;; e-info +;; e-texinfo +;; +;; You can add them for export snippets via any of the below: +;; +;; (add-to-list 'org-export-snippet-translation-alist +;; '("e-info" . "e-texinfo")) +;; (add-to-list 'org-export-snippet-translation-alist +;; '("e-texinfo" . "e-texinfo")) +;; (add-to-list 'org-export-snippet-translation-alist +;; '("info" . "e-texinfo")) +;; + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org-export) + +(defvar orgtbl-exp-regexp) + + +;;; Define Back-End + +(defvar org-e-texinfo-translate-alist + '((babel-call . org-e-texinfo-babel-call) + (bold . org-e-texinfo-bold) + (center-block . org-e-texinfo-center-block) + (clock . org-e-texinfo-clock) + (code . org-e-texinfo-code) + (comment . org-e-texinfo-comment) + (comment-block . org-e-texinfo-comment-block) + (drawer . org-e-texinfo-drawer) + (dynamic-block . org-e-texinfo-dynamic-block) + (entity . org-e-texinfo-entity) + (example-block . org-e-texinfo-example-block) + (export-block . org-e-texinfo-export-block) + (export-snippet . org-e-texinfo-export-snippet) + (fixed-width . org-e-texinfo-fixed-width) + (footnote-definition . org-e-texinfo-footnote-definition) + (footnote-reference . org-e-texinfo-footnote-reference) + (headline . org-e-texinfo-headline) + (horizontal-rule . org-e-texinfo-horizontal-rule) + (inline-babel-call . org-e-texinfo-inline-babel-call) + (inline-src-block . org-e-texinfo-inline-src-block) + (inlinetask . org-e-texinfo-inlinetask) + (italic . org-e-texinfo-italic) + (item . org-e-texinfo-item) + (keyword . org-e-texinfo-keyword) + (latex-environment . org-e-texinfo-latex-environment) + (latex-fragment . org-e-texinfo-latex-fragment) + (line-break . org-e-texinfo-line-break) + (link . org-e-texinfo-link) + (macro . org-e-texinfo-macro) + (paragraph . org-e-texinfo-paragraph) + (plain-list . org-e-texinfo-plain-list) + (plain-text . org-e-texinfo-plain-text) + (planning . org-e-texinfo-planning) + (property-drawer . org-e-texinfo-property-drawer) + (quote-block . org-e-texinfo-quote-block) + (quote-section . org-e-texinfo-quote-section) + (radio-target . org-e-texinfo-radio-target) + (section . org-e-texinfo-section) + (special-block . org-e-texinfo-special-block) + (src-block . org-e-texinfo-src-block) + (statistics-cookie . org-e-texinfo-statistics-cookie) + (strike-through . org-e-texinfo-strike-through) + (subscript . org-e-texinfo-subscript) + (superscript . org-e-texinfo-superscript) + (table . org-e-texinfo-table) + (table-cell . org-e-texinfo-table-cell) + (table-row . org-e-texinfo-table-row) + (target . org-e-texinfo-target) + (template . org-e-texinfo-template) + (timestamp . org-e-texinfo-timestamp) + (underline . org-e-texinfo-underline) + (verbatim . org-e-texinfo-verbatim) + (verse-block . org-e-texinfo-verse-block)) + "Alist between element or object types and translators.") + +(defconst org-e-texinfo-options-alist + '((:texinfo-filename "TEXINFO_FILENAME" nil org-e-texinfo-filename t) + (:texinfo-class "TEXINFO_CLASS" nil org-e-texinfo-default-class t) + (:texinfo-header "TEXINFO_HEADER" nil nil newline) + (:subtitle "SUBTITLE" nil nil newline) + (:subauthor "SUBAUTHOR" nil nil newline) + (:texinfo-dircat "TEXINFO_DIR_CATEGORY" nil nil t) + (:texinfo-dirtitle "TEXINFO_DIR_TITLE" nil nil t) + (:texinfo-dirdesc "TEXINFO_DIR_DESC" nil nil t)) + "Alist between Texinfo export properties and ways to set them. +See `org-export-options-alist' for more information on the +structure of the values. + +SUBAUTHOR and SUBTITLE are for the inclusion of additional author +and title information beyond the initial variable.") + +(defconst org-e-texinfo-filters-alist + '((:filter-headline . org-e-texinfo-filter-section-blank-lines) + (:filter-section . org-e-texinfo-filter-section-blank-lines)) + "Alist between filters keywords and back-end specific filters. + See `org-export-filters-alist' for more information") + + +;;; Internal Variables + +;; Add TEXINFO to the list of available of available export blocks. +(add-to-list 'org-element-block-name-alist + '("TEXINFO" . org-element-export-block-parser)) + +;;; User Configurable Variables + +(defgroup org-export-e-texinfo nil + "Options for exporting Org mode files to Texinfo." + :tag "Org Export Texinfo" + :group 'org-export) + +;;; Preamble + +(defcustom org-e-texinfo-filename nil + "Default filename for texinfo output." + :group 'org-export-e-texinfo + :type '(string :tag "Export Filename")) + +(defcustom org-e-texinfo-default-class "info" + "The default Texinfo class." + :group 'org-export-e-texinfo + :type '(string :tag "Texinfo class")) + +(defcustom org-e-texinfo-classes + '(("info" + "\\input texinfo @c -*- texinfo -*-" + ("@chapter %s" . "@unnumbered %s") + ("@section %s" . "@unnumberedsec %s") + ("@subsection %s" . "@unnumberedsubsec %s") + ("@subsubsection %s" . "@unnumberedsubsubsec %s"))) + "Alist of Texinfo classes and associated header and structure. +If #+Texinfo_CLASS is set in the buffer, use its value and the +associated information. Here is the structure of each cell: + + \(class-name + header-string + \(numbered-section . unnumbered-section\) + ...\) + +The sectioning structure +------------------------ + +The sectioning structure of the class is given by the elements +following the header string. For each sectioning level, a number +of strings is specified. A %s formatter is mandatory in each +section string and will be replaced by the title of the section. + +Instead of a list of sectioning commands, you can also specify +a function name. That function will be called with two +parameters, the \(reduced) level of the headline, and a predicate +non-nil when the headline should be numbered. It must return +a format string in which the section title will be added." + :group 'org-export-e-texinfo + :type '(repeat + (list (string :tag "Texinfo class") + (string :tag "Texinfo header") + (repeat :tag "Levels" :inline t + (choice + (cons :tag "Heading" + (string :tag " numbered") + (string :tag "unnumbered")) + (function :tag "Hook computing sectioning")))))) + +;;; Headline + +(defcustom org-e-texinfo-format-headline-function nil + "Function to format headline text. + +This function will be called with 5 arguments: +TODO the todo keyword (string or nil). +TODO-TYPE the type of todo (symbol: `todo', `done', nil) +PRIORITY the priority of the headline (integer or nil) +TEXT the main headline text (string). +TAGS the tags as a list of strings (list of strings or nil). + +The function result will be used in the section format string. + +As an example, one could set the variable to the following, in +order to reproduce the default set-up: + +\(defun org-e-texinfo-format-headline (todo todo-type priority text tags) + \"Default format function for an headline.\" + \(concat (when todo + \(format \"\\\\textbf{\\\\textsc{\\\\textsf{%s}}} \" todo)) + \(when priority + \(format \"\\\\framebox{\\\\#%c} \" priority)) + text + \(when tags + \(format \"\\\\hfill{}\\\\textsc{%s}\" + \(mapconcat 'identity tags \":\"))))" + :group 'org-export-e-texinfo + :type 'function) + + +;;; Footnotes +;; +;; Footnotes are inserted directly + +;;; Timestamps + +(defcustom org-e-texinfo-active-timestamp-format "@emph{%s}" + "A printf format string to be applied to active timestamps." + :group 'org-export-e-texinfo + :type 'string) + +(defcustom org-e-texinfo-inactive-timestamp-format "@emph{%s}" + "A printf format string to be applied to inactive timestamps." + :group 'org-export-e-texinfo + :type 'string) + +(defcustom org-e-texinfo-diary-timestamp-format "@emph{%s}" + "A printf format string to be applied to diary timestamps." + :group 'org-export-e-texinfo + :type 'string) + +;;; Links + +(defcustom org-e-texinfo-link-with-unknown-path-format "@indicateurl{%s}" + "Format string for links with unknown path type." + :group 'org-export-e-texinfo + :type 'string) + +;;; Tables + +(defcustom org-e-texinfo-tables-verbatim nil + "When non-nil, tables are exported verbatim." + :group 'org-export-e-texinfo + :type 'boolean) + +(defcustom org-e-texinfo-table-scientific-notation "%s\\,(%s)" + "Format string to display numbers in scientific notation. +The format should have \"%s\" twice, for mantissa and exponent +\(i.e. \"%s\\\\times10^{%s}\"). + +When nil, no transformation is made." + :group 'org-export-e-texinfo + :type '(choice + (string :tag "Format string") + (const :tag "No formatting"))) + +(defcustom org-e-texinfo-def-table-markup "@samp" + "Default setting for @table environments.") + +;;; Text markup + +(defcustom org-e-texinfo-text-markup-alist '((bold . "@strong{%s}") + (code . code) + (italic . "@emph{%s}") + (verbatim . verb) + (comment . "@c %s")) + "Alist of Texinfo expressions to convert text markup. + +The key must be a symbol among `bold', `italic' and `comment'. +The value is a formatting string to wrap fontified text with. + +Value can also be set to the following symbols: `verb' and +`code'. For the former, Org will use \"@verb\" to +create a format string and select a delimiter character that +isn't in the string. For the latter, Org will use \"@code\" +to typeset and try to protect special characters. + +If no association can be found for a given markup, text will be +returned as-is." + :group 'org-export-e-texinfo + :type 'alist + :options '(bold code italic verbatim comment)) + +;;; Drawers + +(defcustom org-e-texinfo-format-drawer-function nil + "Function called to format a drawer in Texinfo code. + +The function must accept two parameters: + NAME the drawer name, like \"LOGBOOK\" + CONTENTS the contents of the drawer. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-texinfo-format-drawer-default \(name contents\) + \"Format a drawer element for Texinfo export.\" + contents\)" + :group 'org-export-e-texinfo + :type 'function) + +;;; Inlinetasks + +(defcustom org-e-texinfo-format-inlinetask-function nil + "Function called to format an inlinetask in Texinfo code. + +The function must accept six parameters: + TODO the todo keyword, as a string + TODO-TYPE the todo type, a symbol among `todo', `done' and nil. + PRIORITY the inlinetask priority, as a string + NAME the inlinetask name, as a string. + TAGS the inlinetask tags, as a list of strings. + CONTENTS the contents of the inlinetask, as a string. + +The function should return the string to be exported. + +For example, the variable could be set to the following function +in order to mimic default behaviour: + +\(defun org-e-texinfo-format-inlinetask \(todo type priority name tags contents\) +\"Format an inline task element for Texinfo export.\" + \(let ((full-title + \(concat + \(when todo + \(format \"@strong{%s} \" todo)) + \(when priority (format \"#%c \" priority)) + title + \(when tags + \(format \":%s:\" + \(mapconcat 'identity tags \":\"))))) + \(format (concat \"@center %s\n\n\" + \"%s\" + \"\n\")) + full-title contents))" + :group 'org-export-e-texinfo + :type 'function) + +;;; Src blocks +;; +;; Src Blocks are example blocks, except for LISP + +;;; Plain text + +(defcustom org-e-texinfo-quotes + '(("quotes" + ("\\(\\s-\\|[[(]\\|^\\)\"" . "``") + ("\\(\\S-\\)\"" . "''") + ("\\(\\s-\\|(\\|^\\)'" . "`"))) + "Alist for quotes to use when converting english double-quotes. + +The CAR of each item in this alist is the language code. +The CDR of each item in this alist is a list of three CONS: +- the first CONS defines the opening quote; +- the second CONS defines the closing quote; +- the last CONS defines single quotes. + +For each item in a CONS, the first string is a regexp +for allowed characters before/after the quote, the second +string defines the replacement string for this quote." + :group 'org-export-e-texinfo + :type '(list + (cons :tag "Opening quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")) + (cons :tag "Closing quote" + (string :tag "Regexp for char after ") + (string :tag "Replacement quote ")) + (cons :tag "Single quote" + (string :tag "Regexp for char before") + (string :tag "Replacement quote ")))) + +;;; Compilation + +(defcustom org-e-texinfo-info-process + '("makeinfo %f") + "Commands to process a texinfo file to an INFO file. +This is list of strings, each of them will be given to the shell +as a command. %f in the command will be replaced by the full +file name, %b by the file base name \(i.e without extension) and +%o by the base directory of the file." + :group 'org-export-texinfo + :type '(repeat :tag "Shell command sequence" + (string :tag "Shell command"))) + + +;;; Internal Functions + +(defun org-e-texinfo-filter-section-blank-lines (headline back-end info) + "Filter controlling number of blank lines after a section." + (let ((blanks (make-string 2 ?\n))) + (replace-regexp-in-string "\n\\(?:\n[ \t]*\\)*\\'" blanks headline))) + +(defun org-e-texinfo--find-copying (info) + "Retrieve the headline identified by the property :copying:. + +INFO is the plist containing the export options and tree. It is +used to find and extract the single desired headline. This +cannot be treated as a standard headline since it must be +inserted in a specific location." + (let (copying) + (org-element-map (plist-get info :parse-tree) 'headline + (lambda (copy) + (when (org-element-property :copying copy) + (push copy copying))) info 't) + ;; Retrieve the single entry + (car copying))) + +(defun org-e-texinfo--find-verb-separator (s) + "Return a character not used in string S. +This is used to choose a separator for constructs like \\verb." + (let ((ll "~,./?;':\"|!@#%^&-_=+abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ<>()[]{}")) + (loop for c across ll + when (not (string-match (regexp-quote (char-to-string c)) s)) + return (char-to-string c)))) + +(defun org-e-texinfo--make-option-string (options) + "Return a comma separated string of keywords and values. +OPTIONS is an alist where the key is the options keyword as +a string, and the value a list containing the keyword value, or +nil." + (mapconcat (lambda (pair) + (concat (first pair) + (when (> (length (second pair)) 0) + (concat "=" (second pair))))) + options + ",")) + +(defun org-e-texinfo--quotation-marks (text info) + "Export quotation marks using ` and ' as the markers. +TEXT is a string containing quotation marks to be replaced. INFO +is a plist used as a communication channel." + (mapc (lambda(l) + (let ((start 0)) + (while (setq start (string-match (car l) text start)) + (let ((new-quote (concat (match-string 1 text) (cdr l)))) + (setq text (replace-match new-quote t t text)))))) + (cdr org-e-texinfo-quotes)) + text) + +(defun org-e-texinfo--text-markup (text markup) + "Format TEXT depending on MARKUP text markup. +See `org-e-texinfo-text-markup-alist' for details." + (let ((fmt (cdr (assq markup org-e-texinfo-text-markup-alist)))) + (cond + ;; No format string: Return raw text. + ((not fmt) text) + ((eq 'verb fmt) + (let ((separator (org-e-texinfo--find-verb-separator text))) + (concat "@verb{" separator text separator "}"))) + ((eq 'code fmt) + (let ((start 0) + (rtn "") + char) + (while (string-match "[@{}]" text) + (setq char (match-string 0 text)) + (if (> (match-beginning 0) 0) + (setq rtn (concat rtn (substring text 0 (match-beginning 0))))) + (setq text (substring text (1+ (match-beginning 0)))) + (setq char (concat "@" char) + rtn (concat rtn char))) + (setq text (concat rtn text) + fmt "@code{%s}") + (format fmt text))) + ;; Else use format string. + (t (format fmt text))))) + +;;; Headline sanitizing + +(defun org-e-texinfo--sanitize-headline (headline info) + "Remove all formatting from the text of a headline for use in + node and menu listing." + (mapconcat 'identity + (org-e-texinfo--sanitize-headline-contents headline info) " ")) + +(defun org-e-texinfo--sanitize-headline-contents (headline info) + "Retrieve the content of the headline. + +Any content that can contain further formatting is checked +recursively, to ensure that nested content is also properly +retrieved." + (loop for contents in headline append + (cond + ;; already a string + ((stringp contents) + (list (replace-regexp-in-string " $" "" contents))) + ;; Is exported as-is (value) + ((org-element-map contents '(verbatim code) + (lambda (value) + (org-element-property :value value)))) + ;; Has content and recurse into the content + ((org-element-contents contents) + (org-e-texinfo--sanitize-headline-contents + (org-element-contents contents) info))))) + +;;; Menu sanitizing + +(defun org-e-texinfo--sanitize-menu (title) + "Remove invalid characters from TITLE for use in menus and +nodes. + +Based on TEXINFO specifications, the following must be removed: +@ { } ( ) : . ," + (replace-regexp-in-string "[@{}():,.]" "" title)) + +;;; Content sanitizing + +(defun org-e-texinfo--sanitize-content (text) + "Ensure characters are properly escaped when used in headlines or blocks. + +Escape characters are: @ { }" + (replace-regexp-in-string "\\\([@{}]\\\)" "@\\1" text)) + +;;; Menu creation + +(defun org-e-texinfo--build-menu (tree level info &optional detailed) + "Create the @menu/@end menu information from TREE at headline +level LEVEL. + +TREE contains the parse-tree to work with, either of the entire +document or of a specific parent headline. LEVEL indicates what +level of headlines to look at when generating the menu. INFO is +a plist containing contextual information. + +Detailed determines whether to build a single level of menu, or +recurse into all children as well." + (let ((menu (org-e-texinfo--generate-menu-list tree level info)) + output text-menu) + (cond + (detailed + ;; Looping is done within the menu generation. + (setq text-menu (org-e-texinfo--generate-detailed menu level info))) + (t + (setq text-menu (org-e-texinfo--generate-menu-items menu info)))) + (when text-menu + (setq output (org-e-texinfo--format-menu text-menu)) + (mapconcat 'identity output "\n")))) + +(defun org-e-texinfo--generate-detailed (menu level info) + "Generate a detailed listing of all subheadings within MENU starting at LEVEL. + +MENU is the parse-tree to work with. LEVEL is the starting level +for the menu headlines and from which recursion occurs. INFO is +a plist containing contextual information." + (when level + (let ((max-depth (plist-get info :headline-levels))) + (when (> max-depth level) + (loop for headline in menu append + (let* ((title (org-e-texinfo--menu-headlines headline info)) + ;; Create list of menu entries for the next level + (sublist (org-e-texinfo--generate-menu-list + headline (1+ level) info)) + ;; Generate the menu items for that level. If + ;; there are none omit that heading completely, + ;; otherwise join the title to it's related entries. + (submenu (if (org-e-texinfo--generate-menu-items sublist info) + (append (list title) + (org-e-texinfo--generate-menu-items sublist info)) + 'nil)) + ;; Start the process over the next level down. + (recursion (org-e-texinfo--generate-detailed sublist (1+ level) info))) + (setq recursion (append submenu recursion)) + recursion)))))) + +(defun org-e-texinfo--generate-menu-list (tree level info) + "Generate the list of headlines that are within a given level +of the tree for further formatting. + +TREE is the parse-tree containing the headlines. LEVEL is the +headline level to generate a list of. INFO is a plist holding +contextual information." + (let (seq) + (org-element-map + tree 'headline + (lambda (head) + (when (org-element-property :level head) + (if (and (eq level (org-element-property :level head)) + ;; Do not take note of footnotes or copying headlines + (not (org-element-property :copying head)) + (not (org-element-property :footnote-section-p head))) + (push head seq))))) + ;; Return the list of headlines (reverse to have in actual order) + (reverse seq))) + +(defun org-e-texinfo--generate-menu-items (items info) + "Generate a list of headline information from the listing ITEMS. + +ITEMS is a list of the headlines to be converted into entries. +INFO is a plist containing contextual information. + +Returns a list containing the following information from each +headline: length, title, description. This is used to format the +menu using `org-e-texinfo--format-menu'." + (loop for headline in items collect + (let* ((title (org-e-texinfo--sanitize-menu + (org-e-texinfo--sanitize-headline + (org-element-property :title headline) info))) + (descr (org-export-data + (org-element-property :description headline) info)) + (len (length title)) + (output (list len title descr))) + output))) + +(defun org-e-texinfo--menu-headlines (headline info) + "Retrieve the title from HEADLINE. + +INFO is a plist holding contextual information. + +Return the headline as a list of (length title description) with +length of -1 and nil description. This is used in +`org-e-texinfo--format-menu' to identify headlines as opposed to +entries." + (let ((title (org-export-data + (org-element-property :title headline) info))) + (list -1 title 'nil))) + +(defun org-e-texinfo--format-menu (text-menu) + "Format the TEXT-MENU items to be properly printed in the menu. + +Each entry in the menu should be provided as (length title +description). + +Headlines in the detailed menu are given length -1 to ensure they +are never confused with other entries. They also have no +description. + +Other menu items are output as: + Title:: description + +With the spacing between :: and description based on the length +of the longest menu entry." + + (let* ((lengths (mapcar 'car text-menu)) + (max-length (apply 'max lengths)) + output) + (setq output + (mapcar (lambda (name) + (let* ((title (nth 1 name)) + (desc (nth 2 name)) + (length (nth 0 name))) + (if (> length -1) + (concat "* " title ":: " + (make-string + (- (+ 3 max-length) length) + ?\s) + (if desc + (concat desc))) + (concat "\n" title "\n")))) + text-menu)) + output)) + +;;; Template + +(defun org-e-texinfo-template (contents info) + "Return complete document string after Texinfo conversion. +CONTENTS is the transcoded contents string. INFO is a plist +holding export options." + (let* ((title (org-export-data (plist-get info :title) info)) + (info-filename (or (plist-get info :texinfo-filename) + (file-name-nondirectory + (org-export-output-file-name ".info")))) + (author (org-export-data (plist-get info :author) info)) + (texinfo-header (plist-get info :texinfo-header)) + (subtitle (plist-get info :subtitle)) + (subauthor (plist-get info :subauthor)) + (class (plist-get info :texinfo-class)) + (header (nth 1 (assoc class org-e-texinfo-classes))) + (copying (org-e-texinfo--find-copying info)) + (dircat (plist-get info :texinfo-dircat)) + (dirtitle (plist-get info :texinfo-dirtitle)) + (dirdesc (plist-get info :texinfo-dirdesc)) + ;; Spacing to align description (column 32 - 3 for `* ' and + ;; `.' in text. + (dirspacing (- 29 (length dirtitle))) + (menu (org-e-texinfo-make-menu info 'main)) + (detail-menu (org-e-texinfo-make-menu info 'detailed))) + (concat + ;; Header + header "\n" + "@c %**start of header\n" + ;; Filename and Title + "@setfilename " info-filename "\n" + "@settitle " title "\n" + "\n\n" + "@c Version and Contact Info\n" + "@set AUTHOR " author "\n" + + ;; Additional Header Options set by `#+TEXINFO_HEADER + (if texinfo-header + (concat "\n" + texinfo-header + "\n")) + + "@c %**end of header\n" + "@finalout\n" + "\n\n" + + ;; Copying + "@copying\n" + ;; Only export the content of the headline, do not need the + ;; initial headline. + (org-export-data (nth 2 copying) info) + "@end copying\n" + "\n\n" + + ;; Info directory information + ;; Only supply if both title and category are provided + (if (and dircat dirtitle) + (concat "@dircategory " dircat "\n" + "@direntry\n" + "* " dirtitle "." + (make-string dirspacing ?\s) + dirdesc "\n" + "@end direntry\n")) + "\n\n" + + ;; Title + "@titlepage\n" + "@title " title "\n\n" + (if subtitle + (concat "@subtitle " subtitle "\n")) + "@author " author "\n" + (if subauthor + (concat subauthor "\n")) + "\n" + "@c The following two commands start the copyright page.\n" + "@page\n" + "@vskip 0pt plus 1filll\n" + "@insertcopying\n" + "@end titlepage\n\n" + "@c Output the table of contents at the beginning.\n" + "@contents\n\n" + + ;; Configure Top Node when not for Tex + "@ifnottex\n" + "@node Top\n" + "@top " title " Manual\n" + "@insertcopying\n" + "@end ifnottex\n\n" + + ;; Do not output menus if they are empty + (if menu + ;; Menu + (concat "@menu\n" + menu + "\n\n" + ;; Detailed Menu + (if detail-menu + (concat "@detailmenu\n" + " --- The Detailed Node Listing ---\n" + detail-menu + "\n\n" + "@end detailmenu\n")) + "@end menu\n")) + "\n\n" + + ;; Document's body. + contents + "\n" + ;; Creator. + (let ((creator-info (plist-get info :with-creator))) + (cond + ((not creator-info) "") + ((eq creator-info 'comment) + (format "@c %s\n" (plist-get info :creator))) + (t (concat (plist-get info :creator) "\n")))) + ;; Document end. + "\n@bye"))) + + + +;;; Transcode Functions + +;;; Babel Call +;; +;; Babel Calls are ignored. + +;;; Bold + +(defun org-e-texinfo-bold (bold contents info) + "Transcode BOLD from Org to Texinfo. +CONTENTS is the text with bold markup. INFO is a plist holding +contextual information." + (org-e-texinfo--text-markup contents 'bold)) + +;;; Center Block +;; +;; Center blocks are ignored + +;;; Clock + +(defun org-e-texinfo-clock (clock contents info) + "Transcode a CLOCK element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + (concat + "@noindent" + (format "@strong{%s} " org-clock-string) + (format org-e-texinfo-inactive-timestamp-format + (concat (org-translate-time (org-element-property :value clock)) + (let ((time (org-element-property :time clock))) + (and time (format " (%s)" time))))) + "@*")) + +;;; Code + +(defun org-e-texinfo-code (code contents info) + "Transcode a CODE object from Org to Texinfo. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (org-e-texinfo--text-markup (org-element-property :value code) 'code)) + +;;; Comment + +(defun org-e-texinfo-comment (comment contents info) + "Transcode a COMMENT object from Org to Texinfo. +CONTENTS is the text in the comment. INFO is a plist holding +contextual information." + (org-e-texinfo--text-markup (org-element-property :value comment) 'comment)) + +;;; Comment Block + +(defun org-e-texinfo-comment-block (comment-block contents info) + "Transcode a COMMENT-BLOCK object from Org to Texinfo. +CONTENTS is the text within the block. INFO is a plist holding +contextual information." + (format "@ignore\n%s@end ignore" (org-element-property :value comment-block))) + +;;; Drawer + +(defun org-e-texinfo-drawer (drawer contents info) + "Transcode a DRAWER element from Org to Texinfo. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let* ((name (org-element-property :drawer-name drawer)) + (output (if (functionp org-e-texinfo-format-drawer-function) + (funcall org-e-texinfo-format-drawer-function + name contents) + ;; If there's no user defined function: simply + ;; display contents of the drawer. + contents))) + output)) + +;;; Dynamic Block + +(defun org-e-texinfo-dynamic-block (dynamic-block contents info) + "Transcode a DYNAMIC-BLOCK element from Org to Texinfo. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information. See `org-export-data'." + contents) + +;;; Entity + +(defun org-e-texinfo-entity (entity contents info) + "Transcode an ENTITY object from Org to Texinfo. +CONTENTS are the definition itself. INFO is a plist holding +contextual information." + (let ((ent (org-element-property :latex entity))) + (if (org-element-property :latex-math-p entity) (format "@math{%s}" ent) ent))) + +;;; Example Block + +(defun org-e-texinfo-example-block (example-block contents info) + "Transcode an EXAMPLE-BLOCK element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format "@verbatim\n%s@end verbatim" + (org-export-format-code-default example-block info))) + +;;; Export Block + +(defun org-e-texinfo-export-block (export-block contents info) + "Transcode a EXPORT-BLOCK element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (string= (org-element-property :type export-block) "TEXINFO") + (org-remove-indentation (org-element-property :value export-block)))) + +;;; Export Snippet + +(defun org-e-texinfo-export-snippet (export-snippet contents info) + "Transcode a EXPORT-SNIPPET object from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (when (eq (org-export-snippet-backend export-snippet) 'e-texinfo) + (org-element-property :value export-snippet))) + +;;; Fixed Width + +(defun org-e-texinfo-fixed-width (fixed-width contents info) + "Transcode a FIXED-WIDTH element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (format "@example\n%s\n@end example" + (org-remove-indentation + (org-e-texinfo--sanitize-content + (org-element-property :value fixed-width))))) + +;;; Footnote Definition +;; +;; Footnote Definitions are ignored. + +;;; Footnote Reference +;; + +(defun org-e-texinfo-footnote-reference (footnote contents info) + "Create a footnote reference for FOOTNOTE. + +FOOTNOTE is the footnote to define. CONTENTS is nil. INFO is a +plist holding contextual information." + (let ((def (org-export-get-footnote-definition footnote info))) + (format "@footnote{%s}" + (org-trim (org-export-data def info))))) + +;;; Headline + +(defun org-e-texinfo-headline (headline contents info) + "Transcode an HEADLINE element from Org to Texinfo. +CONTENTS holds the contents of the headline. INFO is a plist +holding contextual information." + (let* ((class (plist-get info :texinfo-class)) + (level (org-export-get-relative-level headline info)) + (numberedp (org-export-numbered-headline-p headline info)) + (class-sectionning (assoc class org-e-texinfo-classes)) + ;; Find the index type, if any + (index (org-element-property :index headline)) + ;; Retrieve headline text + (text (org-e-texinfo--sanitize-headline + (org-element-property :title headline) info)) + ;; Create node info, to insert it before section formatting. + (node (format "@node %s\n" + (org-e-texinfo--sanitize-menu + (replace-regexp-in-string "%" "%%" text)))) + ;; Menus must be generated with first child, otherwise they + ;; will not nest properly + (menu (let* ((first (org-export-first-sibling-p headline info)) + (parent (org-export-get-parent-headline headline)) + (title (org-e-texinfo--sanitize-headline + (org-element-property :title parent) info)) + heading listing + (tree (plist-get info :parse-tree))) + (if first + (org-element-map + (plist-get info :parse-tree) 'headline + (lambda (ref) + (if (member title (org-element-property :title ref)) + (push ref heading))) + info 't)) + (setq listing (org-e-texinfo--build-menu + (car heading) level info)) + (if listing + (setq listing (replace-regexp-in-string + "%" "%%" listing) + listing (format + "\n@menu\n%s\n@end menu\n\n" listing)) + 'nil))) + ;; Section formatting will set two placeholders: one for the + ;; title and the other for the contents. + (section-fmt + (let ((sec (if (and (symbolp (nth 2 class-sectionning)) + (fboundp (nth 2 class-sectionning))) + (funcall (nth 2 class-sectionning) level numberedp) + (nth (1+ level) class-sectionning)))) + (cond + ;; No section available for that LEVEL. + ((not sec) nil) + ;; Section format directly returned by a function. + ((stringp sec) sec) + ;; (numbered-section . unnumbered-section) + ((not (consp (cdr sec))) + ;; If an index, always unnumbered + (if index + (concat menu node (cdr sec) "\n%s") + ;; Otherwise number as needed. + (concat menu node + (funcall + (if numberedp #'car #'cdr) sec) "\n%s")))))) + (todo + (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword headline))) + (and todo (org-export-data todo info))))) + (todo-type (and todo (org-element-property :todo-type headline))) + (tags (and (plist-get info :with-tags) + (org-export-get-tags headline info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority headline))) + ;; Create the headline text along with a no-tag version. The + ;; latter is required to remove tags from table of contents. + (full-text (org-e-texinfo--sanitize-content + (if (functionp org-e-texinfo-format-headline-function) + ;; User-defined formatting function. + (funcall org-e-texinfo-format-headline-function + todo todo-type priority text tags) + ;; Default formatting. + (concat + (when todo + (format "@strong{%s} " todo)) + (when priority (format "@emph{#%s} " priority)) + text + (when tags + (format ":%s:" + (mapconcat 'identity tags ":"))))))) + (full-text-no-tag + (org-e-texinfo--sanitize-content + (if (functionp org-e-texinfo-format-headline-function) + ;; User-defined formatting function. + (funcall org-e-texinfo-format-headline-function + todo todo-type priority text nil) + ;; Default formatting. + (concat + (when todo (format "@strong{%s} " todo)) + (when priority (format "@emph{#%c} " priority)) + text)))) + (pre-blanks + (make-string (org-element-property :pre-blank headline) 10))) + (cond + ;; Case 1: This is a footnote section: ignore it. + ((org-element-property :footnote-section-p headline) nil) + ;; Case 2: This is the `copying' section: ignore it + ;; This is used elsewhere. + ((org-element-property :copying headline) nil) + ;; Case 3: An index. If it matches one of the known indexes, + ;; print it as such following the contents, otherwise + ;; print the contents and leave the index up to the user. + (index + (format + section-fmt full-text + (concat pre-blanks contents "\n" + (if (member index '("cp" "fn" "ky" "pg" "tp" "vr")) + (concat "@printindex " index))))) + ;; Case 4: This is a deep sub-tree: export it as a list item. + ;; Also export as items headlines for which no section + ;; format has been found. + ((or (not section-fmt) (org-export-low-level-p headline info)) + ;; Build the real contents of the sub-tree. + (let ((low-level-body + (concat + ;; If the headline is the first sibling, start a list. + (when (org-export-first-sibling-p headline info) + (format "@%s\n" (if numberedp 'enumerate 'itemize))) + ;; Itemize headline + "@item\n" full-text "\n" pre-blanks contents))) + ;; If headline is not the last sibling simply return + ;; LOW-LEVEL-BODY. Otherwise, also close the list, before any + ;; blank line. + (if (not (org-export-last-sibling-p headline info)) low-level-body + (replace-regexp-in-string + "[ \t\n]*\\'" + (format "\n@end %s" (if numberedp 'enumerate 'itemize)) + low-level-body)))) + ;; Case 5: Standard headline. Export it as a section. + (t + (cond + ((not (and tags (eq (plist-get info :with-tags) 'not-in-toc))) + ;; Regular section. Use specified format string. + (format (replace-regexp-in-string "%]" "%%]" section-fmt) full-text + (concat pre-blanks contents))) + ((string-match "\\`@\\(.*?\\){" section-fmt) + ;; If tags should be removed from table of contents, insert + ;; title without tags as an alternative heading in sectioning + ;; command. + (format (replace-match (concat (match-string 1 section-fmt) "[%s]") + nil nil section-fmt 1) + ;; Replace square brackets with parenthesis since + ;; square brackets are not supported in optional + ;; arguments. + (replace-regexp-in-string + "\\[" "(" + (replace-regexp-in-string + "\\]" ")" + full-text-no-tag)) + full-text + (concat pre-blanks contents))) + (t + ;; Impossible to add an alternative heading. Fallback to + ;; regular sectioning format string. + (format (replace-regexp-in-string "%]" "%%]" section-fmt) full-text + (concat pre-blanks contents)))))))) + +;;; Horizontal Rule +;; +;; Horizontal rules are ignored + +;;; Inline Babel Call +;; +;; Inline Babel Calls are ignored. + +;;; Inline Src Block + +(defun org-e-texinfo-inline-src-block (inline-src-block contents info) + "Transcode an INLINE-SRC-BLOCK element from Org to Texinfo. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((code (org-element-property :value inline-src-block)) + (separator (org-e-texinfo--find-verb-separator code))) + (concat "@verb{" separator code separator "}"))) + +;;; Inlinetask + +(defun org-e-texinfo-inlinetask (inlinetask contents info) + "Transcode an INLINETASK element from Org to Texinfo. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let ((title (org-export-data (org-element-property :title inlinetask) info)) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword inlinetask))) + (and todo (org-export-data todo info))))) + (todo-type (org-element-property :todo-type inlinetask)) + (tags (and (plist-get info :with-tags) + (org-export-get-tags inlinetask info))) + (priority (and (plist-get info :with-priority) + (org-element-property :priority inlinetask)))) + ;; If `org-e-texinfo-format-inlinetask-function' is provided, call it + ;; with appropriate arguments. + (if (functionp org-e-texinfo-format-inlinetask-function) + (funcall org-e-texinfo-format-inlinetask-function + todo todo-type priority title tags contents) + ;; Otherwise, use a default template. + (let ((full-title + (concat + (when todo (format "@strong{%s} " todo)) + (when priority (format "#%c " priority)) + title + (when tags (format ":%s:" + (mapconcat 'identity tags ":")))))) + (format (concat "@center %s\n\n" + "%s" + "\n") + full-title contents))))) + +;;; Italic + +(defun org-e-texinfo-italic (italic contents info) + "Transcode ITALIC from Org to Texinfo. +CONTENTS is the text with italic markup. INFO is a plist holding +contextual information." + (org-e-texinfo--text-markup contents 'italic)) + +;;; Item + +(defun org-e-texinfo-item (item contents info) + "Transcode an ITEM element from Org to Texinfo. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((tag (org-element-property :tag item)) + (desc (org-export-data tag info))) + (concat "\n@item " (if tag desc) "\n" + (org-trim contents) "\n"))) + +;;; Keyword + +(defun org-e-texinfo-keyword (keyword contents info) + "Transcode a KEYWORD element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((key (org-element-property :key keyword)) + (value (org-element-property :value keyword))) + (cond + ((string= key "TEXINFO") value) + ((string= key "CINDEX") (format "@cindex %s" value)) + ((string= key "FINDEX") (format "@findex %s" value)) + ((string= key "KINDEX") (format "@kindex %s" value)) + ((string= key "PINDEX") (format "@pindex %s" value)) + ((string= key "TINDEX") (format "@tindex %s" value)) + ((string= key "VINDEX") (format "@vindex %s" value))))) + +;;; Latex Environment +;; +;; Latex environments are ignored + +;;; Latex Fragment +;; +;; Latex fragments are ignored. + +;;; Line Break + +(defun org-e-texinfo-line-break (line-break contents info) + "Transcode a LINE-BREAK object from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + "@*") + +;;; Link + +(defun org-e-texinfo-link (link desc info) + "Transcode a LINK object from Org to Texinfo. + +DESC is the description part of the link, or the empty string. +INFO is a plist holding contextual information. See +`org-export-data'." + (let* ((type (org-element-property :type link)) + (raw-path (org-element-property :path link)) + ;; Ensure DESC really exists, or set it to nil. + (desc (and (not (string= desc "")) desc)) + (path (cond + ((member type '("http" "https" "ftp")) + (concat type ":" raw-path)) + ((string= type "file") + (when (string-match "\\(.+\\)::.+" raw-path) + (setq raw-path (match-string 1 raw-path))) + (if (file-name-absolute-p raw-path) + (concat "file://" (expand-file-name raw-path)) + (concat "file://" raw-path))) + (t raw-path))) + (email (if (string= type "mailto") + (let ((text (replace-regexp-in-string + "@" "@@" raw-path))) + (concat text (if desc (concat "," desc)))))) + protocol) + (cond + ;; Links pointing to an headline: Find destination and build + ;; appropriate referencing command. + ((member type '("custom-id" "id")) + (let ((destination (org-export-resolve-id-link link info))) + (case (org-element-type destination) + ;; Id link points to an external file. + (plain-text + (if desc (format "@uref{file://%s,%s}" destination desc) + (format "@uref{file://%s}" destination))) + ;; LINK points to an headline. Use the headline as the NODE target + (headline + (format "@ref{%s}" + (org-export-data + (org-element-property :title destination) info))) + (otherwise + (let ((path (org-export-solidify-link-text path))) + (if (not desc) (format "@ref{%s}" path) + (format "@ref{%s,,%s}" path desc))))))) + ((member type '("fuzzy")) + (let ((destination (org-export-resolve-fuzzy-link link info))) + (case (org-element-type destination) + ;; Id link points to an external file. + (plain-text + (if desc (format "@uref{file://%s,%s}" destination desc) + (format "@uref{file://%s}" destination))) + ;; LINK points to an headline. Use the headline as the NODE target + (headline + (format "@ref{%s}" + (org-export-data + (org-element-property :title destination) info))) + (otherwise + (let ((path (org-export-solidify-link-text path))) + (if (not desc) (format "@ref{%s}" path) + (format "@ref{%s,,%s}" path desc))))))) + ;; Special case for email addresses + (email + (format "@email{%s}" email)) + ;; External link with a description part. + ((and path desc) (format "@uref{%s,%s}" path desc)) + ;; External link without a description part. + (path (format "@uref{%s}" path)) + ;; No path, only description. Try to do something useful. + (t (format org-e-texinfo-link-with-unknown-path-format desc))))) + +;;; Macro + +(defun org-e-texinfo-macro (macro contents info) + "Transcode a MACRO element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + ;; Use available tools. + (org-export-expand-macro macro info)) + +;;; Menu + +(defun org-e-texinfo-make-menu (info level) + "Create the menu for inclusion in the texifo document. + +INFO is the parsed buffer that contains the headlines. LEVEL +determines whether to make the main menu, or the detailed menu. + +This is only used for generating the primary menu. In-Node menus +are generated directly." + (let* ((parse (plist-get info :parse-tree)) + ;; Top determines level to build menu from, it finds the + ;; level of the first headline in the export. + (top (org-element-map + parse 'headline + (lambda (headline) + (org-element-property :level headline)) info 't))) + (cond + ;; Generate the main menu + ((eq level 'main) + (org-e-texinfo--build-menu parse top info)) + ;; Generate the detailed (recursive) menu + ((eq level 'detailed) + ;; Requires recursion + ;;(org-e-texinfo--build-detailed-menu parse top info) + (org-e-texinfo--build-menu parse top info 'detailed)) + ;; Otherwise do nothing + (t)))) + +;;; Paragraph + +(defun org-e-texinfo-paragraph (paragraph contents info) + "Transcode a PARAGRAPH element from Org to Texinfo. +CONTENTS is the contents of the paragraph, as a string. INFO is +the plist used as a communication channel." + contents) + +;;; Plain List + +(defun org-e-texinfo-plain-list (plain-list contents info) + "Transcode a PLAIN-LIST element from Org to Texinfo. +CONTENTS is the contents of the list. INFO is a plist holding +contextual information." + (let* ((attr (org-export-read-attribute :attr_texinfo plain-list)) + (indic (or (plist-get attr :indic) + org-e-texinfo-def-table-markup)) + (type (org-element-property :type plain-list)) + (table-type (or (plist-get attr :table-type) + "table")) + ;; Ensure valid texinfo table type. + (table-type (if (memq table-type '("table" "ftable" "vtable")) + table-type + "table")) + (list-type (cond + ((eq type 'ordered) "enumerate") + ((eq type 'unordered) "itemize") + ((eq type 'descriptive) table-type)))) + (format "@%s%s\n@end %s" + (if (eq type 'descriptive) + (concat list-type " " indic) + list-type) + contents + list-type))) + +;;; Plain Text + +(defun org-e-texinfo-plain-text (text info) + "Transcode a TEXT string from Org to Texinfo. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; LaTeX into @LaTeX{} and TeX into @TeX{} + (let ((case-fold-search nil) + (start 0)) + (while (string-match "\\(\\(?:La\\)?TeX\\)" text start) + (setq text (replace-match + (format "@%s{}" (match-string 1 text)) nil t text) + start (match-end 0)))) + ;; Handle quotation marks + (setq text (org-e-texinfo--quotation-marks text info)) + ;; Convert special strings. + (when (plist-get info :with-special-strings) + (while (string-match (regexp-quote "...") text) + (setq text (replace-match "@dots{}" nil t text)))) + ;; Handle break preservation if required. + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string "\\(\\\\\\\\\\)?[ \t]*\n" " @*\n" + text))) + ;; Return value with @ { and } protected. + (org-e-texinfo--sanitize-content text)) + +;;; Planning + +(defun org-e-texinfo-planning (planning contents info) + "Transcode a PLANNING element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + (concat + "@noindent" + (mapconcat + 'identity + (delq nil + (list + (let ((closed (org-element-property :closed planning))) + (when closed + (concat + (format "@strong%s} " org-closed-string) + (format org-e-texinfo-inactive-timestamp-format + (org-translate-time closed))))) + (let ((deadline (org-element-property :deadline planning))) + (when deadline + (concat + (format "@strong{%s} " org-deadline-string) + (format org-e-texinfo-active-timestamp-format + (org-translate-time deadline))))) + (let ((scheduled (org-element-property :scheduled planning))) + (when scheduled + (concat + (format "@strong{%s} " org-scheduled-string) + (format org-e-texinfo-active-timestamp-format + (org-translate-time scheduled))))))) + " ") + "@*")) + +;;; Property Drawer + +(defun org-e-texinfo-property-drawer (property-drawer contents info) + "Transcode a PROPERTY-DRAWER element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + ;; The property drawer isn't exported but we want separating blank + ;; lines nonetheless. + "") + +;;; Quote Block + +(defun org-e-texinfo-quote-block (quote-block contents info) + "Transcode a QUOTE-BLOCK element from Org to Texinfo. +CONTENTS holds the contents of the block. INFO is a plist +holding contextual information." + (let* ((title (org-element-property :name quote-block)) + (start-quote (concat "@quotation" + (if title + (format " %s" title))))) + (format "%s\n%s@end quotation" start-quote contents))) + +;;; Quote Section + +(defun org-e-texinfo-quote-section (quote-section contents info) + "Transcode a QUOTE-SECTION element from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (let ((value (org-remove-indentation + (org-element-property :value quote-section)))) + (when value (format "@verbatim\n%s@end verbatim" value)))) + +;;; Radio Target + +(defun org-e-texinfo-radio-target (radio-target text info) + "Transcode a RADIO-TARGET object from Org to Texinfo. +TEXT is the text of the target. INFO is a plist holding +contextual information." + (format "@anchor{%s}%s" + (org-export-solidify-link-text + (org-element-property :value radio-target)) + text)) + +;;; Section + +(defun org-e-texinfo-section (section contents info) + "Transcode a SECTION element from Org to Texinfo. +CONTENTS holds the contents of the section. INFO is a plist +holding contextual information." + contents) + +;;; Special Block +;; +;; Are ignored at the moment + +;;; Src Block + +(defun org-e-texinfo-src-block (src-block contents info) + "Transcode a SRC-BLOCK element from Org to Texinfo. +CONTENTS holds the contents of the item. INFO is a plist holding +contextual information." + (let* ((lang (org-element-property :language src-block)) + (lisp-p (string-match-p "lisp" lang))) + (cond + ;; Case 1. Lisp Block + (lisp-p + (format "@lisp\n%s\n@end lisp" + (org-export-format-code-default src-block info))) + ;; Case 2. Other blocks + (t + (format "@example\n%s\n@end example" + (org-export-format-code-default src-block info)))))) + +;;; Statistics Cookie + +(defun org-e-texinfo-statistics-cookie (statistics-cookie contents info) + "Transcode a STATISTICS-COOKIE object from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual information." + (org-element-property :value statistics-cookie)) + +;;; Strike-Through +;; +;; Strikethrough is ignored + +;;; Subscript + +(defun org-e-texinfo-subscript (subscript contents info) + "Transcode a SUBSCRIPT object from Org to Texinfo. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "@math{_%s}" contents)) + +;;; Superscript + +(defun org-e-texinfo-superscript (superscript contents info) + "Transcode a SUPERSCRIPT object from Org to Texinfo. +CONTENTS is the contents of the object. INFO is a plist holding +contextual information." + (format "@math{^%s}" contents)) + +;;; Table +;; +;; `org-e-texinfo-table' is the entry point for table transcoding. It +;; takes care of tables with a "verbatim" attribute. Otherwise, it +;; delegates the job to either `org-e-texinfo-table--table.el-table' or +;; `org-e-texinfo-table--org-table' functions, depending of the type of +;; the table. +;; +;; `org-e-texinfo-table--align-string' is a subroutine used to build +;; alignment string for Org tables. + +(defun org-e-texinfo-table (table contents info) + "Transcode a TABLE element from Org to Texinfo. +CONTENTS is the contents of the table. INFO is a plist holding +contextual information." + (cond + ;; Case 1: verbatim table. + ((or org-e-texinfo-tables-verbatim + (let ((attr (mapconcat 'identity + (org-element-property :attr_latex table) + " "))) + (and attr (string-match "\\<verbatim\\>" attr)))) + (format "@verbatim \n%s\n@end verbatim" + ;; Re-create table, without affiliated keywords. + (org-trim + (org-element-interpret-data + `(table nil ,@(org-element-contents table)))))) + ;; Case 2: table.el table. Convert it using appropriate tools. + ((eq (org-element-property :type table) 'table.el) + (org-e-texinfo-table--table.el-table table contents info)) + ;; Case 3: Standard table. + (t (org-e-texinfo-table--org-table table contents info)))) + +(defun org-e-texinfo-table-column-widths (table info) + "Determine the largest table cell in each column to process alignment. + +TABLE is the table element to transcode. INFO is a plist used as +a communication channel." + (let* ((rows (org-element-map table 'table-row 'identity info)) + (collected (loop for row in rows collect + (org-element-map + row 'table-cell 'identity info))) + (number-cells (length (car collected))) + cells counts) + (loop for row in collected do + (push (mapcar (lambda (ref) + (let* ((start (org-element-property :contents-begin ref)) + (end (org-element-property :contents-end ref)) + (length (- end start))) + length)) row) cells)) + (setq cells (remove-if #'null cells)) + (push (loop for count from 0 to (- number-cells 1) collect + (loop for item in cells collect + (nth count item))) counts) + (mapconcat (lambda (size) + (make-string size ?a)) (mapcar (lambda (ref) + (apply 'max `,@ref)) (car counts)) + "} {"))) + +(defun org-e-texinfo-table--org-table (table contents info) + "Return appropriate Texinfo code for an Org table. + +TABLE is the table type element to transcode. CONTENTS is its +contents, as a string. INFO is a plist used as a communication +channel. + +This function assumes TABLE has `org' as its `:type' attribute." + (let* ((attr (org-export-read-attribute :attr_texinfo table)) + (col-width (plist-get attr :columns)) + (columns (if col-width + (format "@columnfractions %s" + col-width) + (format "{%s}" + (org-e-texinfo-table-column-widths + table info))))) + ;; Prepare the final format string for the table. + (cond + ;; Longtable. + ;; Others. + (t (concat + (format "@multitable %s\n%s@end multitable" + columns + contents)))))) + +(defun org-e-texinfo-table--table.el-table (table contents info) + "Returns nothing. + +Rather than return an invalid table, nothing is returned." + 'nil) + +;;; Table Cell + +(defun org-e-texinfo-table-cell (table-cell contents info) + "Transcode a TABLE-CELL element from Org to Texinfo. +CONTENTS is the cell contents. INFO is a plist used as +a communication channel." + (concat (if (and contents + org-e-texinfo-table-scientific-notation + (string-match orgtbl-exp-regexp contents)) + ;; Use appropriate format string for scientific + ;; notation. + (format org-e-texinfo-table-scientific-notation + (match-string 1 contents) + (match-string 2 contents)) + contents) + (when (org-export-get-next-element table-cell info) "\n@tab "))) + +;;; Table Row + +(defun org-e-texinfo-table-row (table-row contents info) + "Transcode a TABLE-ROW element from Org to Texinfo. +CONTENTS is the contents of the row. INFO is a plist used as +a communication channel." + ;; Rules are ignored since table separators are deduced from + ;; borders of the current row. + (when (eq (org-element-property :type table-row) 'standard) + (concat "@item " contents "\n"))) + +;;; Target + +(defun org-e-texinfo-target (target contents info) + "Transcode a TARGET object from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + (format "@anchor{%s}" + (org-export-solidify-link-text (org-element-property :value target)))) + +;;; Timestamp + +(defun org-e-texinfo-timestamp (timestamp contents info) + "Transcode a TIMESTAMP object from Org to Texinfo. +CONTENTS is nil. INFO is a plist holding contextual +information." + (let ((value (org-translate-time (org-element-property :value timestamp))) + (type (org-element-property :type timestamp))) + (cond ((memq type '(active active-range)) + (format org-e-texinfo-active-timestamp-format value)) + ((memq type '(inactive inactive-range)) + (format org-e-texinfo-inactive-timestamp-format value)) + (t (format org-e-texinfo-diary-timestamp-format value))))) + +;;; Underline +;; +;; Underline is ignored + +;;; Verbatim + +(defun org-e-texinfo-verbatim (verbatim contents info) + "Transcode a VERBATIM object from Org to Texinfo. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (org-e-texinfo--text-markup (org-element-property :value verbatim) 'verbatim)) + +;;; Verse Block + +(defun org-e-texinfo-verse-block (verse-block contents info) + "Transcode a VERSE-BLOCK element from Org to Texinfo. +CONTENTS is verse block contents. INFO is a plist holding +contextual information." + ;; In a verse environment, add a line break to each newline + ;; character and change each white space at beginning of a line + ;; into a space of 1 em. Also change each blank line with + ;; a vertical space of 1 em. + (progn + (setq contents (replace-regexp-in-string + "^ *\\\\\\\\$" "\\\\vspace*{1em}" + (replace-regexp-in-string + "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" contents))) + (while (string-match "^[ \t]+" contents) + (let ((new-str (format "\\hspace*{%dem}" + (length (match-string 0 contents))))) + (setq contents (replace-match new-str nil t contents)))) + (format "\\begin{verse}\n%s\\end{verse}" contents))) + + +;;; Interactive functions + +(defun org-e-texinfo-export-to-texinfo + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to a Texinfo file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".texi" subtreep pub-dir))) + (org-export-to-file + 'e-texinfo outfile subtreep visible-only body-only ext-plist))) + +(defun org-e-texinfo-export-to-info + (&optional subtreep visible-only body-only ext-plist pub-dir) + "Export current buffer to Texinfo then process through to INFO. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only write code +between \"\\begin{document}\" and \"\\end{document}\". + +EXT-PLIST, when provided, is a property list with external +parameters overriding Org default settings, but still inferior to +file-local settings. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return INFO file's name." + (interactive) + (org-e-texinfo-compile + (org-e-texinfo-export-to-texinfo + subtreep visible-only body-only ext-plist pub-dir))) + +(defun org-e-texinfo-compile (texifile) + "Compile a texinfo file. + +TEXIFILE is the name of the file being compiled. Processing is +done through the command specified in `org-e-texinfo-info-process'. + +Return INFO file name or an error if it couldn't be produced." + (let* ((wconfig (current-window-configuration)) + (texifile (file-truename texifile)) + (base (file-name-sans-extension texifile)) + errors) + (message (format "Processing Texinfo file %s ..." texifile)) + (unwind-protect + (progn + (cond + ;; A function is provided: Apply it. + ((functionp org-e-texinfo-info-process) + (funcall org-e-texinfo-info-process (shell-quote-argument texifile))) + ;; A list is provided: Replace %b, %f and %o with appropriate + ;; values in each command before applying it. Output is + ;; redirected to "*Org INFO Texinfo Output*" buffer. + ((consp org-e-texinfo-info-process) + (let* ((out-dir (or (file-name-directory texifile) "./")) + (outbuf (get-buffer-create "*Org Info Texinfo Output*"))) + (mapc + (lambda (command) + (shell-command + (replace-regexp-in-string + "%b" (shell-quote-argument base) + (replace-regexp-in-string + "%f" (shell-quote-argument texifile) + (replace-regexp-in-string + "%o" (shell-quote-argument out-dir) command t t) t t) t t) + outbuf)) + org-e-texinfo-info-process) + ;; Collect standard errors from output buffer. + (setq errors (org-e-texinfo-collect-errors outbuf)))) + (t (error "No valid command to process to Info"))) + (let ((infofile (concat base ".info"))) + ;; Check for process failure. Provide collected errors if + ;; possible. + (if (not (file-exists-p infofile)) + (error (concat (format "INFO file %s wasn't produced" infofile) + (when errors (concat ": " errors)))) + ;; Else remove log files, when specified, and signal end of + ;; process to user, along with any error encountered. + (message (concat "Process completed" + (if (not errors) "." + (concat " with errors: " errors))))) + ;; Return output file name. + infofile)) + (set-window-configuration wconfig)))) + +(defun org-e-texinfo-collect-errors (buffer) + "Collect some kind of errors from \"makeinfo\" command output. + +BUFFER is the buffer containing output. + +Return collected error types as a string, or nil if there was +none." + (with-current-buffer buffer + (save-excursion + (goto-char (point-min)) + ;; Find final "makeinfo" run. + (when t + (let ((case-fold-search t) + (errors "")) + (when (save-excursion + (re-search-forward "perhaps incorrect sectioning?" nil t)) + (setq errors (concat errors " [incorrect sectionnng]"))) + (when (save-excursion + (re-search-forward "missing close brace" nil t)) + (setq errors (concat errors " [syntax error]"))) + (when (save-excursion + (re-search-forward "Unknown command" nil t)) + (setq errors (concat errors " [undefined @command]"))) + (when (save-excursion + (re-search-forward "No matching @end" nil t)) + (setq errors (concat errors " [block incomplete]"))) + (when (save-excursion + (re-search-forward "requires a sectioning" nil t)) + (setq errors (concat errors " [invalid section command]"))) + (when (save-excursion + (re-search-forward "\\[unexpected\]" nil t)) + (setq errors (concat errors " [unexpected error]"))) + (when (save-excursion + (re-search-forward "misplaced " nil t)) + (setq errors (concat errors " [syntax error]"))) + (and (org-string-nw-p errors) (org-trim errors))))))) + +(provide 'org-e-texinfo) +;;; org-e-texinfo.el ends here diff --git a/contrib/lisp/org-elisp-symbol.el b/contrib/lisp/org-elisp-symbol.el new file mode 100644 index 0000000..96b0e5d --- /dev/null +++ b/contrib/lisp/org-elisp-symbol.el @@ -0,0 +1,161 @@ +;;; org-elisp-symbol.el --- Org links to emacs-lisp symbols +;; +;; Copyright 2007-2012 Free Software Foundation, Inc. +;; +;; Author: bzg AT gnu DOT org +;; Version: 0.2 +;; Keywords: org, remember, lisp +;; URL: http://www.cognition.ens.fr/~guerry/u/org-elisp-symbol.el +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; Commentary: +;; +;; Org-mode already lets you store/insert links to emacs-lisp files, +;; just like any other file. This package lets you precisely link to +;; any emacs-lisp symbol and access useful information about the symbol. +;; +;; Here is the list of available properties when linking from a elisp-symbol: +;; +;; :name The symbol's name. +;; :stype The symbol's type (commandp, function, etc.) +;; :def The function used to set the symbol's value (defun, etc.) +;; :keys The keys associated with the command. +;; :args The arguments of the function. +;; :docstring The docstring of the symbol. +;; :doc The first line of the dostring. +;; :comment A comment line just above the sexp, if any. +;; :fixme A FIXME comment line just above the sexp, if any. +;; +;; Let's say we have a defun like this one: +;; +;; ;; FIXME update docstring +;; (defun org-export-latex-lists () +;; "Convert lists to LaTeX." +;; (goto-char (point-min)) +;; (while (re-search-forward org-export-latex-list-beginning-re nil t) +;; (beginning-of-line) +;; (insert (org-list-to-latex (org-list-parse-list t)) "\n"))) +;; +;; And a remember template like: +;; +;; (setq org-remember-templates +;; '((?s "* DEBUG `%:name' (%:args)\n\n%?\n\nFixme: %:fixme\n \ +;; Doc: \"%:doc\"\n\n%a"))) +;; +;; Then M-x `org-remember' on this sexp will produce this buffer: +;; +;; ===================================================================== +;; * DEBUG `org-export-latex-lists' () +;; +;; <== point +;; +;; Fixme: update the docstring +;; Doc: "Convert lists to LaTeX." +;; +;; [[file:~/path/file.el::defun%20my-func][Function: my-func]] +;; ===================================================================== +;; +;; Put this file into your load-path and the following into your ~/.emacs: +;; (require 'org-elisp-symbol) + +;;; Code: + +(provide 'org-elisp-symbol) + +(require 'org) + +(org-add-link-type "elisp-symbol" 'org-elisp-symbol-open) +(add-hook 'org-store-link-functions 'org-elisp-symbol-store-link) + +(defun org-elisp-symbol-open (path) + "Visit the emacs-lisp elisp-symbol at PATH." + (let* ((search (when (string-match "::\\(.+\\)\\'" path) + (match-string 1 path))) + (path (substring path 0 (match-beginning 0)))) + (org-open-file path t nil search))) + +(defun org-elisp-symbol-store-link () + "Store a link to an emacs-lisp elisp-symbol." + (when (eq major-mode 'emacs-lisp-mode) + (save-excursion + (or (looking-at "^(") (beginning-of-defun)) + (looking-at "^(\\([a-z]+\\) \\([^)\n ]+\\) ?\n?[ \t]*\\(?:(\\(.*\\))\\)?") + (let* ((end (save-excursion + (save-match-data + (end-of-defun) (point)))) + (def (match-string 1)) + (name (match-string 2)) + (sym-name (intern-soft name)) + (stype (cond ((commandp sym-name) "Command") + ((functionp sym-name) "Function") + ((user-variable-p sym-name) "User variable") + ((string= def "defvar") "Variable") + ((string= def "defmacro") "Macro") + ((string= def "defun") "Function or command") + (t "Symbol"))) + (args (if (match-string 3) + (mapconcat (lambda (a) (unless (string-match "^&" a) a)) + (split-string (match-string 3)) " ") + "no arg")) + (docstring (cond ((functionp sym-name) + (or (documentation sym-name) + "[no documentation]")) + ((string-match "[Vv]ariable" stype) + (documentation-property sym-name + 'variable-documentation)) + (t "no documentation"))) + (doc (and (string-match "^\\([^\n]+\\)$" docstring) + (match-string 1 docstring))) + (fixme (save-excursion + (beginning-of-defun) (end-of-defun) + (if (re-search-forward "^;+ ?FIXME[ :]*\\(.*\\)$" end t) + (match-string 1) "nothing to fix"))) + (comment (save-excursion + (beginning-of-defun) (end-of-defun) + (if (re-search-forward "^;;+ ?\\(.*\\)$" end t) + (match-string 1) "no comment"))) + keys keys-desc link description) + (if (equal stype "Command") + (setq keys (where-is-internal sym-name) + keys-desc + (if keys (mapconcat 'key-description keys " ") "none"))) + (setq link (concat "file:" (abbreviate-file-name buffer-file-name) + "::" def " " name)) + (setq description (concat stype ": " name)) + (org-store-link-props + :type "elisp-symbol" + :link link + :description description + :def def + :name name + :stype stype + :args args + :keys keys-desc + :docstring docstring + :doc doc + :fixme fixme + :comment comment))))) + +(provide 'org-elisp-symbol) + + +;;;;########################################################################## +;;;; User Options, Variables +;;;;########################################################################## + +;;; org-elisp-symbol.el ends here diff --git a/contrib/lisp/org-eval-light.el b/contrib/lisp/org-eval-light.el new file mode 100644 index 0000000..36f3c6d --- /dev/null +++ b/contrib/lisp/org-eval-light.el @@ -0,0 +1,201 @@ +;;; org-eval-light.el --- Display result of evaluating code in various languages (light) + +;; Copyright (C) 2008-2012 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org>, +;; Eric Schulte <schulte dot eric at gmail dot com> +;; Keywords: outlines, hypermedia, calendar, wp, literate programming, +;; reproducible research +;; Homepage: http://orgmode.org +;; Version: 0.04 + +;; This file is not yet part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file is based off of org-eval, with the following changes. +;; +;; 1) forms are only executed manually, (allowing for the execution of +;; an entire subtree of forms) +;; 2) use the org-mode style src blocks, rather than the muse style +;; <code></code> blocks +;; 3) forms are not replaced by their outputs, but rather the output +;; is placed in the buffer immediately following the src block +;; commented by `org-eval-light-make-region-example' (when +;; evaluated with a prefix argument no output is placed in the +;; buffer) +;; 4) add defadvice to org-ctrl-c-ctrl-c so that when called inside of +;; a source block it will call `org-eval-light-current-snippet' + +;;; Code: +(require 'org) + +(defgroup org-eval-light nil + "Options concerning including output from commands into the Org-mode buffer." + :tag "Org Eval" + :group 'org) + +(defvar org-eval-light-example-size-cutoff 10 + "The number of lines under which an example is considered +'small', and is exported with the '^:' syntax instead of in a +large example block") + +(defvar org-eval-light-regexp nil) + +(defun org-eval-light-set-interpreters (var value) + (set-default var value) + (setq org-eval-light-regexp + (concat "#\\+begin_src \\(" + (mapconcat 'regexp-quote value "\\|") + "\\)\\([^\000]+?\\)#\\+end_src"))) + +(defcustom org-eval-light-interpreters '("lisp" "emacs-lisp" "ruby" "shell") + "Interpreters allows for evaluation tags. +This is a list of program names (as strings) that can evaluate code and +insert the output into an Org-mode buffer. Valid choices are + +lisp Interpret Emacs Lisp code and display the result +shell Pass command to the shell and display the result +perl The perl interpreter +python Thy python interpreter +ruby The ruby interpreter" + :group 'org-eval-light + :set 'org-eval-light-set-interpreters + :type '(set :greedy t + (const "lisp") + (const "emacs-lisp") + (const "perl") + (const "python") + (const "ruby") + (const "shell"))) + +;;; functions +(defun org-eval-light-inside-snippet () + (interactive) + (save-excursion + (let ((case-fold-search t) + (start-re "^#\\+begin_src\\( \\([^ \t\n]+\\)\\)?.*\n") + (end-re "\n#\\+end_src") + (pos (point)) + beg end) + (if (and (setq beg (re-search-backward start-re nil t)) + (setq end (re-search-forward end-re nil t)) + (<= beg pos) (>= end pos)) + t)))) + +(defun org-eval-light-make-region-example (beg end) + "Comment out region using either the '^:' or the BEGIN_EXAMPLE +syntax based on the size of the region as compared to +`org-eval-light-example-size-cutoff'." + (interactive "*r") + (let ((size (abs (- (line-number-at-pos end) + (line-number-at-pos beg))))) + (if (= size 0) + (let ((result (buffer-substring beg end))) + (delete-region beg end) + (insert (concat ": " result))) + (if (<= size org-eval-light-example-size-cutoff) + (save-excursion + (goto-char beg) + (dotimes (n size) + (move-beginning-of-line 1) (insert ": ") (forward-line 1))) + (let ((result (buffer-substring beg end))) + (delete-region beg end) + (insert (concat "#+BEGIN_EXAMPLE\n" result "#+END_EXAMPLE\n"))))))) + +(defun org-eval-light-current-snippet (&optional arg) + "Execute the current #+begin_src #+end_src block, and dump the +results into the buffer immediately following the src block, +commented by `org-eval-light-make-region-example'." + (interactive "P") + (let ((line (org-current-line)) + (case-fold-search t) + (info (org-edit-src-find-region-and-lang)) + beg end lang result) + (setq beg (nth 0 info) + end (nth 1 info) + lang (nth 2 info)) + (unless (member lang org-eval-light-interpreters) + (error "Language is not in `org-eval-light-interpreters': %s" lang)) + (goto-line line) + (setq result (org-eval-light-code lang (buffer-substring beg end))) + (unless arg + (save-excursion + (re-search-forward "^#\\+end_src" nil t) (open-line 1) (forward-char 2) + (let ((beg (point)) + (end (progn (insert result) + (point)))) + (message (format "from %S %S" beg end)) + (org-eval-light-make-region-example beg end)))))) + +(defun org-eval-light-eval-subtree (&optional arg) + "Replace EVAL snippets in the entire subtree." + (interactive "P") + (save-excursion + (org-narrow-to-subtree) + (goto-char (point-min)) + (while (re-search-forward org-eval-light-regexp nil t) + (org-eval-light-current-snippet arg)) + (widen))) + +(defun org-eval-light-code (interpreter code) + (cond + ((member interpreter '("lisp" "emacs-lisp")) + (org-eval-light-lisp (concat "(progn\n" code "\n)"))) + ((equal interpreter "shell") + (shell-command-to-string code)) + ((member interpreter '("perl" "python" "ruby")) + (org-eval-light-run (executable-find interpreter) code)) + (t (error "Cannot evaluate code type %s" interpreter)))) + +(defun org-eval-light-lisp (form) + "Evaluate the given form and return the result as a string." + (require 'pp) + (save-match-data + (condition-case err + (let ((object (eval (read form)))) + (cond + ((stringp object) object) + ((and (listp object) + (not (eq object nil))) + (let ((string (pp-to-string object))) + (substring string 0 (1- (length string))))) + ((numberp object) + (number-to-string object)) + ((eq object nil) "") + (t + (pp-to-string object)))) + (error + (org-display-warning (format "%s: Error evaluating %s: %s" + "???" form err)) + "; INVALID LISP CODE")))) + +(defun org-eval-light-run (cmd code) + (with-temp-buffer + (insert code) + (shell-command-on-region (point-min) (point-max) cmd nil 'replace) + (buffer-string))) + +(defadvice org-ctrl-c-ctrl-c (around org-cc-eval-source activate) + (if (org-eval-light-inside-snippet) + (call-interactively 'org-eval-light-current-snippet) + ad-do-it)) + +(provide 'org-eval-light) + +;;; org-eval-light.el ends here diff --git a/contrib/lisp/org-eval.el b/contrib/lisp/org-eval.el new file mode 100644 index 0000000..9968669 --- /dev/null +++ b/contrib/lisp/org-eval.el @@ -0,0 +1,219 @@ +;;; org-eval.el --- Display result of evaluating code in various languages +;; Copyright (C) 2008-2012 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 0.04 +;; +;; This file is not yet part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This modules allows to include output from various commands into an +;; Org-mode buffer, both for live display, and for export. +;; This technique has been copied from emacs-wiki and Emacs Muse, and +;; we try to make it work here in a way as similar as possible to +;; Muse, so that people who move between both worlds don't need to learn +;; new syntax. +;; +;; Basically it works like this: +;; +;; <lisp>(concat "aaa" "bbb")</lisp> +;; +;; will display "aaabbb" in the buffer and export like that as well. +;; The leading lisp tag will also accept the attributes "markup" and +;; "lang", to specify how the text should be formatted during export. +;; For example, +;; +;; <lisp markup="src" lang="emacs-lisp"> .... </lisp> +;; +;; will format the result of the lisp form as if it was lisp source +;; code. Internally, it will wrap the text into a +;; +;; #+begin_src emacs-lisp +;; #+end_src +;; +;; structure so that the right things happen when the exporter is running. +;; +;; By default, only the <lisp> tag is turned on, but you can configure +;; the variable `org-eval-interpreters' to add more interpreters like +;; `perl', `python', or the `shell'. +;; +;; You can edit the code snippets with "C-c '" (org-edit-src-code). +;; +;; Please note that this mechanism is potentially dangerous, because it +;; executes code that you don't even see. This gives you great power, +;; but also enough rope to hang yourself. And, it gives your friends +;; who send you Org files plenty of opportunity for good and bad jokes. +;; This is also why this module is not turned on by default, but only +;; available as a contributed package. +;; +;; +;; +(require 'org) + +;;; Customization + +(defgroup org-eval nil + "Options concerning including output from commands into the Org-mode buffer." + :tag "Org Eval" + :group 'org) + +(defface org-eval + (org-compatible-face nil + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey40")) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey60")) + (((class color) (min-colors 8) (background light)) + (:foreground "green")) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow")))) + "Face for command output that is included into an Org-mode buffer." + :group 'org-eval + :group 'org-faces + :version "22.1") + +(defvar org-eval-regexp nil) + +(defun org-eval-set-interpreters (var value) + (set-default var value) + (setq org-eval-regexp + (concat "<\\(" + (mapconcat 'regexp-quote value "\\|") + "\\)" + "\\([^>]\\{0,50\\}?\\)>" + "\\([^\000]+?\\)</\\1>"))) + +(defcustom org-eval-interpreters '("lisp") + "Interpreters allows for evaluation tags. +This is a list of program names (as strings) that can evaluate code and +insert the output into an Org-mode buffer. Valid choices are + +lisp Interpret Emacs Lisp code and display the result +shell Pass command to the shell and display the result +perl The perl interpreter +python Thy python interpreter +ruby The ruby interpreter" + :group 'org-eval + :set 'org-eval-set-interpreters + :type '(set :greedy t + (const "lisp") + (const "perl") + (const "python") + (const "ruby") + (const "shell"))) + +(defun org-eval-handle-snippets (limit &optional replace) + "Evaluate code snippets and display the results as display property. +When REPLACE is non-nil, replace the code region with the result (used +for export)." + (let (a) + (while (setq a (text-property-any (point) (or limit (point-max)) + 'org-eval t)) + (remove-text-properties + a (next-single-property-change a 'org-eval nil limit) + '(display t intangible t org-eval t)))) + (while (re-search-forward org-eval-regexp limit t) + (let* ((beg (match-beginning 0)) + (end (match-end 0)) + (kind (match-string 1)) + (attr (match-string 2)) + (code (match-string 3)) + (value (org-eval-code kind code)) + markup lang) + (if replace + (progn + (setq attr (save-match-data (org-eval-get-attributes attr)) + markup (cdr (assoc "markup" attr)) + lang (cdr (assoc "lang" attr))) + (replace-match + (concat (if markup (format "#+BEGIN_%s" (upcase markup))) + (if (and markup (equal (downcase markup) "src")) + (concat " " (or lang "fundamental"))) + "\n" + value + (if markup (format "\n#+END_%s\n" (upcase markup)))) + t t)) + (add-text-properties + beg end + (list 'display value 'intangible t 'font-lock-multiline t + 'face 'org-eval + 'org-eval t)))))) + +(defun org-eval-replace-snippts () + "Replace EVAL snippets in the entire buffer. +This should go into the `org-export-preprocess-hook'." + (goto-char (point-min)) + (org-eval-handle-snippets nil 'replace)) + +(add-hook 'org-export-preprocess-hook 'org-eval-replace-snippts) +(add-hook 'org-font-lock-hook 'org-eval-handle-snippets) + +(defun org-eval-get-attributes (str) + (let ((start 0) key value rtn) + (while (string-match "\\<\\([a-zA-Z]+\\)\\>=\"\\([^\"]+\\)\"" str start) + (setq key (match-string 1 str) + value (match-string 2 str) + start (match-end 0)) + (push (cons key value) rtn)) + rtn)) + +(defun org-eval-code (interpreter code) + (cond + ((equal interpreter "lisp") + (org-eval-lisp (concat "(progn\n" code "\n)"))) + ((equal interpreter "shell") + (shell-command-to-string code)) + ((member interpreter '("perl" "python" "ruby")) + (org-eval-run (executable-find interpreter) code)) + (t (error "Cannot evaluate code type %s" interpreter)))) + +(defun org-eval-lisp (form) + "Evaluate the given form and return the result as a string." + (require 'pp) + (save-match-data + (condition-case err + (let ((object (eval (read form)))) + (cond + ((stringp object) object) + ((and (listp object) + (not (eq object nil))) + (let ((string (pp-to-string object))) + (substring string 0 (1- (length string))))) + ((numberp object) + (number-to-string object)) + ((eq object nil) "") + (t + (pp-to-string object)))) + (error + (org-display-warning (format "%s: Error evaluating %s: %s" + "???" form err)) + "; INVALID LISP CODE")))) + +(defun org-eval-run (cmd code) + (with-temp-buffer + (insert code) + (shell-command-on-region (point-min) (point-max) cmd nil 'replace) + (buffer-string))) + +(provide 'org-eval) + +;;; org-eval.el ends here diff --git a/contrib/lisp/org-exp-bibtex.el b/contrib/lisp/org-exp-bibtex.el new file mode 100644 index 0000000..8a99243 --- /dev/null +++ b/contrib/lisp/org-exp-bibtex.el @@ -0,0 +1,148 @@ +;;; org-exp-bibtex.el --- Export bibtex fragments + +;; Copyright (C) 2009-2012 Taru Karttunen + +;; Author: Taru Karttunen <taruti@taruti.net> + +;; This file is not currently part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or (at +;; your option) any later version. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program ; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: +;; +;; This is an utility to handle BibTeX export to both LaTeX and html +;; exports. It uses the bibtex2html software from +;; http://www.lri.fr/~filliatr/bibtex2html/ +;; +;; The usage is as follows: +;; #+BIBLIOGRAPHY: bibfilebasename stylename optional-options +;; e.g. given foo.bib and using style plain: +;; #+BIBLIOGRAPHY: foo plain option:-d +;; +;; Optional options are of the form: +;; +;; option:-foobar pass '-foobar' to bibtex2html +;; e.g. +;; option:-d sort by date. +;; option:-a sort as BibTeX (usually by author) *default* +;; option:-u unsorted i.e. same order as in .bib file +;; option:-r reverse the sort. +;; see the bibtex2html man page for more. Multiple options can be combined like: +;; option:-d option:-r +;; +;; Limiting to only the entries cited in the document: +;; limit:t + +;; For LaTeX export this simply inserts the lines +;; \bibliographystyle{plain} +;; \bibliography{foo} +;; into the tex-file when exporting. + +;; For Html export it: +;; 1) converts all \cite{foo} to links to the bibliography +;; 2) creates a foo.html and foo_bib.html +;; 3) includes the contents of foo.html in the exported html file + +(require 'org) +(require 'org-exp) + +(defvar org-export-current-backend) ; dynamically bound in org-exp.el +(defun org-export-bibtex-preprocess () + "Export all BibTeX." + (interactive) + (save-window-excursion + (setq oebp-cite-plist '()) + + ;; Convert #+BIBLIOGRAPHY: name style + (goto-char (point-min)) + (while (re-search-forward "^#\\+BIBLIOGRAPHY:[ \t]+\\(\\S-+\\)[ \t]+\\(\\S-+\\)\\([^\r\n]*\\)" nil t) + (let ((file (match-string 1)) + (style (match-string 2)) + (opt (org-exp-bibtex-options-to-plist (match-string 3)))) + (replace-match + (cond + ((eq org-export-current-backend 'html) ;; We are exporting to HTML + (let (extra-args cite-list end-hook tmp-files) + (dolist (elt opt) + (when (equal "option" (car elt)) + (setq extra-args (cons (cdr elt) extra-args)))) + + (when (assoc "limit" opt) ;; Limit is true - collect references + (org-exp-bibtex-docites (lambda () + (dolist (c (org-split-string (match-string 1) ",")) + (add-to-list 'cite-list c)))) +;; (message "cites: %s" cite-list) + (let ((tmp (make-temp-file "org-exp-bibtex"))) + (with-temp-file tmp (dolist (i cite-list) (insert (concat i "\n")))) + (setq tmp-files (cons tmp tmp-files)) + (setq extra-args (append extra-args `("-citefile" ,tmp))))) + + (when (not (eq 0 (apply 'call-process (append '("bibtex2html" nil nil nil) + `("-a" "--nodoc" "--style" ,style "--no-header") + extra-args + (list (concat file ".bib")))))) + (error "Executing bibtex2html failed")) + + (dolist (f tmp-files) (delete-file f))) + + (with-temp-buffer + (save-match-data + (insert-file-contents (concat file ".html")) + (goto-char (point-min)) + (while (re-search-forward (org-re "a name=\"\\([-_[:word:]]+\\)\">\\([[:word:]]+\\)") nil t) + (setq oebp-cite-plist (cons (cons (match-string 1) (match-string 2)) oebp-cite-plist))) + (goto-char (point-min)) + (while (re-search-forward "<hr>" nil t) + (replace-match "<hr/>" t t)) + (concat "\n#+BEGIN_HTML\n<div id=\"bibliography\">\n<h2>References</h2>\n" (buffer-string) "\n</div>\n#+END_HTML\n")))) + ((eq org-export-current-backend 'latex) ;; Latex export + (concat "\n#+LATEX: \\bibliographystyle{" style "}" + "\n#+LATEX: \\bibliography{" file "}\n"))) t t))) + + ;; Convert cites to links in html + (when (eq org-export-current-backend 'html) + ;; Split citation commands with multiple keys + (org-exp-bibtex-docites + (lambda () + (let ((keys (save-match-data (org-split-string (match-string 1) ",")))) + (when (> (length keys) 1) + (replace-match (mapconcat (lambda (k) (format "\\cite{%s}" k)) keys "") + t t))))) + ;; Replace the citation commands with links + (org-exp-bibtex-docites + (lambda () (let* ((cn (match-string 1)) + (cv (assoc cn oebp-cite-plist))) +;; (message "L: %s" (concat "\[_{}[[" cn "][" (if cv (cdr cv) cn) "]]\]")) + (replace-match (concat "\[_{}[[#" cn "][" (if cv (cdr cv) cn) "]]\]")) t t)))))) + +(defun org-exp-bibtex-docites (fun) + (save-excursion + (save-match-data + (goto-char (point-min)) + (when (eq org-export-current-backend 'html) + (while (re-search-forward "\\\\cite{\\([^}\n]+\\)}" nil t) + (apply fun nil)))))) + +(defun org-exp-bibtex-options-to-plist (options) + (save-match-data + (flet ((f (o) (let ((s (split-string o ":"))) (cons (nth 0 s) (nth 1 s))))) + (mapcar 'f (split-string options nil t))))) + +(add-hook 'org-export-preprocess-hook 'org-export-bibtex-preprocess) + +(provide 'org-exp-bibtex) + +;;; org-exp-bibtex.el ends here diff --git a/contrib/lisp/org-expiry.el b/contrib/lisp/org-expiry.el new file mode 100644 index 0000000..9f4517d --- /dev/null +++ b/contrib/lisp/org-expiry.el @@ -0,0 +1,361 @@ +;;; org-expiry.el --- expiry mechanism for Org entries +;; +;; Copyright 2007-2012 Free Software Foundation, Inc. +;; +;; Author: bzg AT gnu DOT org +;; Version: 0.2 +;; Keywords: org expiry + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; Commentary: +;; +;; This gives you a chance to get rid of old entries in your Org files +;; by expiring them. +;; +;; By default, entries that have no EXPIRY property are considered to be +;; new (i.e. 0 day old) and only entries older than one year go to the +;; expiry process, which consist in adding the ARCHIVE tag. None of +;; your tasks will be deleted with the default settings. +;; +;; When does an entry expires? +;; +;; Consider this entry: +;; +;; * Stop watching TV +;; :PROPERTIES: +;; :CREATED: <2008-01-07 lun 08:01> +;; :EXPIRY: <2008-01-09 08:01> +;; :END: +;; +;; This entry will expire on the 9th, january 2008. + +;; * Stop watching TV +;; :PROPERTIES: +;; :CREATED: <2008-01-07 lun 08:01> +;; :EXPIRY: +1w +;; :END: +;; +;; This entry will expire on the 14th, january 2008, one week after its +;; creation date. +;; +;; What happen when an entry is expired? Nothing until you explicitely +;; M-x org-expiry-process-entries When doing this, org-expiry will check +;; for expired entries and request permission to process them. +;; +;; Processing an expired entries means calling the function associated +;; with `org-expiry-handler-function'; the default is to add the tag +;; :ARCHIVE:, but you can also add a EXPIRED keyword or even archive +;; the subtree. +;; +;; Is this useful? Well, when you're in a brainstorming session, it +;; might be useful to know about the creation date of an entry, and be +;; able to archive those entries that are more than xxx days/weeks old. +;; +;; When you're in such a session, you can insinuate org-expiry like +;; this: M-x org-expiry-insinuate +;; +;; Then, each time you're pressing M-RET to insert an item, the CREATION +;; property will be automatically added. Same when you're scheduling or +;; deadlining items. You can deinsinuate: M-x org-expiry-deinsinuate + +;;; Code: + +;;; User variables: + +(defgroup org-expiry nil + "Org expiry process." + :tag "Org Expiry" + :group 'org) + +(defcustom org-expiry-inactive-timestamps nil + "Insert inactive timestamps for the created and expired time properties" + :type 'boolean + :group 'org-expiry) + +(defcustom org-expiry-created-property-name "CREATED" + "The name of the property for setting the creation date." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-expiry-property-name "EXPIRY" + "The name of the property for setting the expiry date/delay." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-keyword "EXPIRED" + "The default keyword for `org-expiry-add-keyword'." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-wait "+1y" + "Time span between the creation date and the expiry. +The default value for this variable (\"+1y\") means that entries +will expire if there are at least one year old. + +If the expiry delay cannot be retrieved from the entry or the +subtree above, the expiry process compares the expiry delay with +`org-expiry-wait'. This can be either an ISO date or a relative +time specification. See `org-read-date' for details." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-created-date "+0d" + "The default creation date. +The default value of this variable (\"+0d\") means that entries +without a creation date will be handled as if they were created +today. + +If the creation date cannot be retrieved from the entry or the +subtree above, the expiry process will compare the expiry delay +with this date. This can be either an ISO date or a relative +time specification. See `org-read-date' for details on relative +time specifications." + :type 'string + :group 'org-expiry) + +(defcustom org-expiry-handler-function 'org-toggle-archive-tag + "Function to process expired entries. +Possible candidates for this function are: + +`org-toggle-archive-tag' +`org-expiry-add-keyword' +`org-expiry-archive-subtree'" + :type 'function + :group 'org-expiry) + +(defcustom org-expiry-confirm-flag t + "Non-nil means confirm expiration process." + :type '(choice + (const :tag "Always require confirmation" t) + (const :tag "Do not require confirmation" nil) + (const :tag "Require confirmation in interactive expiry process" + interactive)) + :group 'org-expiry) + +(defcustom org-expiry-advised-functions + '(org-scheduled org-deadline org-time-stamp) + "A list of advised functions. +`org-expiry-insinuate' will activate the expiry advice for these +functions. `org-expiry-deinsinuate' will deactivate them." + :type 'boolean + :group 'list) + +;;; Advices and insinuation: + +(defadvice org-schedule (after org-schedule-update-created) + "Update the creation-date property when calling `org-schedule'." + (org-expiry-insert-created)) + +(defadvice org-deadline (after org-deadline-update-created) + "Update the creation-date property when calling `org-deadline'." + (org-expiry-insert-created)) + +(defadvice org-time-stamp (after org-time-stamp-update-created) + "Update the creation-date property when calling `org-time-stamp'." + (org-expiry-insert-created)) + +(defun org-expiry-insinuate (&optional arg) + "Add hooks and activate advices for org-expiry. +If ARG, also add a hook to `before-save-hook' in `org-mode' and +restart `org-mode' if necessary." + (interactive "P") + (ad-activate 'org-schedule) + (ad-activate 'org-time-stamp) + (ad-activate 'org-deadline) + (add-hook 'org-insert-heading-hook 'org-expiry-insert-created) + (add-hook 'org-after-todo-state-change-hook 'org-expiry-insert-created) + (add-hook 'org-after-tags-change-hook 'org-expiry-insert-created) + (when arg + (add-hook 'org-mode-hook + (lambda() (add-hook 'before-save-hook + 'org-expiry-process-entries t t))) + ;; need this to refresh org-mode hooks + (when (eq major-mode 'org-mode) + (org-mode) + (if (org-called-interactively-p) + (message "Org-expiry insinuated, `org-mode' restarted."))))) + +(defun org-expiry-deinsinuate (&optional arg) + "Remove hooks and deactivate advices for org-expiry. +If ARG, also remove org-expiry hook in Org's `before-save-hook' +and restart `org-mode' if necessary." + (interactive "P") + (ad-deactivate 'org-schedule) + (ad-deactivate 'org-time-stamp) + (ad-deactivate 'org-deadline) + (remove-hook 'org-insert-heading-hook 'org-expiry-insert-created) + (remove-hook 'org-after-todo-state-change-hook 'org-expiry-insert-created) + (remove-hook 'org-after-tags-change-hook 'org-expiry-insert-created) + (remove-hook 'org-mode-hook + (lambda() (add-hook 'before-save-hook + 'org-expiry-process-entries t t))) + (when arg + ;; need this to refresh org-mode hooks + (when (eq major-mode 'org-mode) + (org-mode) + (if (org-called-interactively-p) + (message "Org-expiry de-insinuated, `org-mode' restarted."))))) + +;;; org-expiry-expired-p: + +(defun org-expiry-expired-p () + "Check if the entry at point is expired. +Return nil if the entry is not expired. Otherwise return the +amount of time between today and the expiry date. + +If there is no creation date, use `org-expiry-created-date'. +If there is no expiry date, use `org-expiry-expiry-date'." + (let* ((ex-prop org-expiry-expiry-property-name) + (cr-prop org-expiry-created-property-name) + (ct (current-time)) + (cr (org-read-date nil t (or (org-entry-get (point) cr-prop t) "+0d"))) + (ex-field (or (org-entry-get (point) ex-prop t) org-expiry-wait)) + (ex (if (string-match "^[ \t]?[+-]" ex-field) + (time-add cr (time-subtract (org-read-date nil t ex-field) ct)) + (org-read-date nil t ex-field)))) + (if (time-less-p ex ct) + (time-subtract ct ex)))) + +;;; Expire an entry or a region/buffer: + +(defun org-expiry-process-entry (&optional force) + "Call `org-expiry-handler-function' on entry. +If FORCE is non-nil, don't require confirmation from the user. +Otherwise rely on `org-expiry-confirm-flag' to decide." + (interactive "P") + (save-excursion + (when (org-called-interactively-p) (org-reveal)) + (when (org-expiry-expired-p) + (org-back-to-heading) + (looking-at org-complex-heading-regexp) + (let* ((ov (make-overlay (point) (match-end 0))) + (e (org-expiry-expired-p)) + (d (time-to-number-of-days e))) + (overlay-put ov 'face 'secondary-selection) + (if (or force + (null org-expiry-confirm-flag) + (and (eq org-expiry-confirm-flag 'interactive) + (not (interactive))) + (and org-expiry-confirm-flag + (y-or-n-p (format "Entry expired by %d days. Process? " d)))) + (funcall 'org-expiry-handler-function)) + (delete-overlay ov))))) + +(defun org-expiry-process-entries (beg end) + "Process all expired entries between BEG and END. +The expiry process will run the function defined by +`org-expiry-handler-functions'." + (interactive "r") + (save-excursion + (let ((beg (if (org-region-active-p) + (region-beginning) (point-min))) + (end (if (org-region-active-p) + (region-end) (point-max)))) + (goto-char beg) + (let ((expired 0) (processed 0)) + (while (and (outline-next-heading) (< (point) end)) + (when (org-expiry-expired-p) + (setq expired (1+ expired)) + (if (if (org-called-interactively-p) + (call-interactively 'org-expiry-process-entry) + (org-expiry-process-entry)) + (setq processed (1+ processed))))) + (if (equal expired 0) + (message "No expired entry") + (message "Processed %d on %d expired entries" + processed expired)))))) + +;;; Insert created/expiry property: + +(defun org-expiry-insert-created (&optional arg) + "Insert or update a property with the creation date. +If ARG, always update it. With one `C-u' prefix, silently update +to today's date. With two `C-u' prefixes, prompt the user for to +update the date." + (interactive "P") + (let* ((d (org-entry-get (point) org-expiry-created-property-name)) + d-time d-hour timestr) + (when (or (null d) arg) + ;; update if no date or non-nil prefix argument + ;; FIXME Use `org-time-string-to-time' + (setq d-time (if d (org-time-string-to-time d) + (current-time))) + (setq d-hour (format-time-string "%H:%M" d-time)) + (setq timestr + ;; two C-u prefixes will call org-read-date + (if (equal arg '(16)) + (concat "<" (org-read-date + nil nil nil nil d-time d-hour) ">") + (format-time-string (cdr org-time-stamp-formats)))) + ;; maybe transform to inactive timestamp + (if org-expiry-inactive-timestamps + (setq timestr (concat "[" (substring timestr 1 -1) "]"))) + (save-excursion + (org-entry-put + (point) org-expiry-created-property-name timestr))))) + +(defun org-expiry-insert-expiry (&optional today) + "Insert a property with the expiry date. +With one `C-u' prefix, don't prompt interactively for the date +and insert today's date." + (interactive "P") + (let* ((d (org-entry-get (point) org-expiry-expiry-property-name)) + d-time d-hour) + (setq d-time (if d (org-time-string-to-time d) + (current-time))) + (setq d-hour (format-time-string "%H:%M" d-time)) + (setq timestr (if today + (format-time-string (cdr org-time-stamp-formats)) + (concat "<" (org-read-date + nil nil nil nil d-time d-hour) ">"))) + ;; maybe transform to inactive timestamp + (if org-expiry-inactive-timestamps + (setq timestr (concat "[" (substring timestr 1 -1) "]"))) + + (save-excursion + (org-entry-put + (point) org-expiry-expiry-property-name timestr)))) + +;;; Functions to process expired entries: + +(defun org-expiry-archive-subtree () + "Archive the entry at point if it is expired." + (interactive) + (save-excursion + (if (org-expiry-expired-p) + (org-archive-subtree) + (if (org-called-interactively-p) + (message "Entry at point is not expired."))))) + +(defun org-expiry-add-keyword (&optional keyword) + "Add KEYWORD to the entry at point if it is expired." + (interactive "sKeyword: ") + (if (or (member keyword org-todo-keywords-1) + (setq keyword org-expiry-keyword)) + (save-excursion + (if (org-expiry-expired-p) + (org-todo keyword) + (if (org-called-interactively-p) + (message "Entry at point is not expired.")))) + (error "\"%s\" is not a to-do keyword in this buffer" keyword))) + +;; FIXME what about using org-refile ? + +(provide 'org-expiry) + +;;; org-expiry.el ends here diff --git a/contrib/lisp/org-export-generic.el b/contrib/lisp/org-export-generic.el new file mode 100644 index 0000000..4de38c7 --- /dev/null +++ b/contrib/lisp/org-export-generic.el @@ -0,0 +1,1504 @@ +;; org-export-generic.el --- Export frameworg with custom backends + +;; Copyright (C) 2009-2012 Free Software Foundation, Inc. + +;; Author: Wes Hardaker <hardaker at users dot sourceforge dot net> +;; Keywords: outlines, hypermedia, calendar, wp, export +;; Homepage: http://orgmode.org +;; Version: 6.25trans +;; Acks: Much of this code was stolen form the ascii export from Carsten +;; +;; This file is not yet part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;; +;; ---------------------------------------------------------------------- +;; +;; OVERVIEW +;; +;; org-export-generic is basically a simple translation system that +;; knows how to parse at least most of a .org buffer and then add +;; various formatting prefixes before and after each section type. It +;; does this by examining a property list stored in org-generic-alist. +;; You can dynamically add propety lists of your own using the +;; org-set-generic-type function: +;; +;; (org-set-generic-type +;; "really-basic-text" +;; '(:file-suffix ".txt" +;; :key-binding ?R +;; +;; :title-format "=== %s ===\n" +;; :body-header-section-numbers t +;; :body-header-section-number-format "%s) " +;; :body-section-header-prefix "\n" +;; :body-section-header-suffix "\n" +;; :body-line-format " %s\n" +;; :body-line-wrap 75 +;; )) +;; +;; Note: Upper case key-bindings are reserved for your use. Lower +;; case key bindings may conflict with future export-generic +;; publications. +;; +;; Then run org-export (ctrl-c ctrl-e) and select generic or run +;; org-export-generic. You'll then be prompted with a list of export +;; types to choose from which will include your new type assigned to +;; the key "r". +;; +;; ---------------------------------------------------------------------- +;; +;; TODO (non-ordered) +;; * handle function references +;; * handle other types of multi-complex-listy-things to do +;; ideas: (t ?- "%s" ?-) +;; * handle indent specifiers better +;; ideas: (4 ?\ "%s") +;; * need flag to remove indents from body text +;; * handle links +;; * handle internationalization strings better +;; * date/author/etc needs improvment (internationalization too) +;; * allow specifying of section ordering +;; ideas: :ordering ("header" "toc" "body" "footer") +;; ^ matches current hard coded ordering +;; * err, actually *do* a footer +;; * deal with usage of org globals +;; *** should we even consider them, or let the per-section specifiers do it +;; *** answer: remove; mostly removed now +;; * deal with interactive support for picking a export specifier label +;; * char specifiers that need extra length because of formatting +;; idea: (?- 4) for 4-longer +;; * centering specifier +;; idea: ('center " -- %s -- ") +;; * remove more of the unneeded export-to-ascii copy code +;; * tags +;; *** supported now, but need separate format per tag +;; *** allow different open/closing prefixes +;; * properties +;; * drawers +;; * Escape camel-case for wiki exporters. +;; * Adjust to depth limits on headers --- need to roll-over from headers +;; to lists, as per other exporters +;; * optmization (many plist extracts should be in let vars) +;; * define defcustom spec for the specifier list +;; * fonts: at least monospace is not handled at all here. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +(require 'org-exp) +(require 'assoc) +(eval-when-compile (require 'cl)) + +(defgroup org-export-generic nil + "Options specific for ASCII export of Org-mode files." + :tag "Org Export ASCII" + :group 'org-export) + +(defcustom org-export-generic-links-to-notes t + "Non-nil means convert links to notes before the next headline. +When nil, the link will be exported in place. If the line becomes long +in this way, it will be wrapped." + :group 'org-export-generic + :type 'boolean) + + +(defvar org-generic-current-indentation nil) ; For communication + +(defvar org-generic-alist + '( + ;; + ;; generic DEMO exporter + ;; + ;; (this tries to use every specifier for demo purposes) + ;; + ("demo" + :file-suffix ".txt" + :key-binding ?d + + :header-prefix "<header>\n" + :header-suffix "</header>\n" + + :author-export t + :tags-export t + + :drawers-export t + + + :title-prefix ?= + :title-format "<h1>%s</h1>\n" + :title-suffix ?= + + :date-export t + :date-prefix "<date>" + :date-format "<br /><b>Date:</b> <i>%s</i><br />" + :date-suffix "</date>\n\n" + + :toc-export t + :toc-header-prefix "<tocname>\n" + :toc-header-format "__%s__\n" + :toc-header-suffix "</tocname>\n" + + :toc-prefix "<toc>\n" + :toc-suffix "</toc>\n" + + :toc-section-numbers t + :toc-section-number-format "\#(%s) " + :toc-format "--%s--" + :toc-format-with-todo "!!%s!!\n" + :toc-indent-char ?\ + :toc-indent-depth 4 + + :toc-tags-export t + :toc-tags-prefix " <tags>" + :toc-tags-format "*%s*" + :toc-tags-suffix "</tags>\n" + :toc-tags-none-string "\n" + + :body-header-section-numbers 3 ; t = all, nil = none + + ; lists indicate different things per level + ; list contents or straight value can either be a + ; ?x char reference for printing strings that match the header len + ; "" string to print directly + :body-section-header-prefix ("<h1>" "<h2>" "<h3>" + "<h4>" "<h5>" "<h6>") + :body-section-header-format "%s" + :body-section-header-suffix ("</h1>\n" "</h2>\n" "</h3>\n" + "</h4>\n" "</h5>\n" "</h6>\n") + + :timestamps-export t + :priorities-export t + :todo-keywords-export t + + :body-tags-export t + :body-tags-prefix " <tags>" + :body-tags-suffix "</tags>\n" + + ; section prefixes/suffixes can be direct strings or lists as well + :body-section-prefix "<secprefix>\n" + :body-section-suffix "</secsuffix>\n" + ; :body-section-prefix ("<sec1>\n" "<sec2>\n" "<sec3>\n") + ; :body-section-suffix ("</sec1>\n" "</sec2>\n" "</sec3>\n") + + + ; if preformated text should be included (eg, : prefixed) + :body-line-export-preformated t + :body-line-fixed-prefix "<pre>\n" + :body-line-fixed-suffix "\n</pre>\n" + :body-line-fixed-format "%s\n" + + + :body-list-prefix "<list>\n" + :body-list-suffix "</list>\n" + :body-list-format "<li>%s</li>\n" + + :body-number-list-prefix "<ol>\n" + :body-number-list-suffix "</ol>\n" + :body-number-list-format "<li>%s</li>\n" + :body-number-list-leave-number t + + :body-list-checkbox-todo "<checkbox type=\"todo\">" + :body-list-checkbox-todo-end "</checkbox (todo)>" + :body-list-checkbox-done "<checkbox type=\"done\">" + :body-list-checkbox-done-end "</checkbox (done)>" + :body-list-checkbox-half "<checkbox type=\"half\">" + :body-list-checkbox-half-end "</checkbox (half)>" + + + + + ; other body lines + :body-line-format "%s" + :body-line-wrap 60 ; wrap at 60 chars + + ; print above and below all body parts + :body-text-prefix "<p>\n" + :body-text-suffix "</p>\n" + + ) + + ;; + ;; ascii exporter + ;; + ;; (close to the original ascii specifier) + ;; + ("ascii" + :file-suffix ".txt" + :key-binding ?a + + :header-prefix "" + :header-suffix "" + + :title-prefix ?= + :title-format "%s\n" + :title-suffix ?= + + :date-export t + :date-prefix "" + :date-format "Date: %s\n" + :date-suffix "" + + :toc-header-prefix "" + :toc-header-format "%s\n" + :toc-header-suffix ?= + + :toc-export t + :toc-section-numbers t + :toc-section-number-format "%s " + :toc-format "%s\n" + :toc-format-with-todo "%s (*)\n" + :toc-indent-char ?\ + :toc-indent-depth 4 + + :body-header-section-numbers 3 + :body-section-prefix "\n" + + ; :body-section-header-prefix "\n" + ; :body-section-header-format "%s\n" + ; :body-section-header-suffix (?\$ ?\# ?^ ?\~ ?\= ?\-) + + :body-section-header-prefix ("" "" "" "* " " + " " - ") + :body-section-header-format "%s\n" + :body-section-header-suffix (?~ ?= ?- "\n" "\n" "\n") + + ; :body-section-marker-prefix "" + ; :body-section-marker-chars (?\$ ?\# ?^ ?\~ ?\= ?\-) + ; :body-section-marker-suffix "\n" + + :body-line-export-preformated t + :body-line-format "%s\n" + :body-line-wrap 75 + + ; :body-text-prefix "<t>\n" + ; :body-text-suffix "</t>\n" + + + :body-bullet-list-prefix (?* ?+ ?-) + ; :body-bullet-list-suffix (?* ?+ ?-) + ) + + ;; + ;; wikipedia + ;; + ("wikipedia" + :file-suffix ".txt" + :key-binding ?w + + :header-prefix "" + :header-suffix "" + + :title-format "= %s =\n" + + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + :body-section-prefix "\n" + + :body-section-header-prefix ("= " "== " "=== " + "==== " "===== " "====== ") + :body-section-header-suffix (" =\n\n" " ==\n\n" " ===\n\n" + " ====\n\n" " =====\n\n" " ======\n\n") + + :body-line-export-preformated t ;; yes/no/maybe??? + :body-line-format "%s\n" + :body-line-wrap 75 + + :body-line-fixed-format " %s\n" + + :body-list-format "* %s\n" + :body-number-list-format "# %s\n" + + :body-bullet-list-prefix ("* " "** " "*** " "**** " "***** ") + ) + ;; + ;; mediawiki + ;; + ("mediawiki" + :file-suffix ".txt" + :key-binding ?m + + :header-prefix "" + :header-suffix "" + + :title-format "= %s =\n" + + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + :body-section-prefix "\n" + + :body-section-header-prefix ("= " "== " "=== " + "==== " "===== " "====== ") + :body-section-header-suffix (" =\n\n" " ==\n\n" " ===\n\n" + " ====\n\n" " =====\n\n" " ======\n\n") + + :body-line-export-preformated t ;; yes/no/maybe??? + :body-line-format "%s\n" + :body-line-wrap 75 + + :body-line-fixed-format " %s\n" + + :body-list-format "* %s\n" + :body-number-list-format "# %s\n" + + :body-bullet-list-prefix ("* " "** " "*** " "**** " "***** ") + :body-list-checkbox-todo "☐ " + :body-list-checkbox-done "☒ " + :body-table-start "{|" + :body-table-end "|}" + :body-table-cell-start "|" + :body-table-cell-end "\n" + :body-table-last-cell-end "|-" + :body-table-hline-start "" + + + ) + ;; + ;; internet-draft .xml for xml2rfc exporter + ;; + ("ietfid" + ;; this tries to use every specifier for demo purposes + :file-suffix ".xml" + :key-binding ?i + + :title-prefix "<?xml version=\"1.0\"\?> +<!DOCTYPE rfc SYSTEM \"rfc2629.dtd\" [ +<!ENTITY rfcs PUBLIC '' 'blah'> +<?rfc strict=\"yes\" ?> +<?rfc toc=\"yes\" ?> +<?rfc tocdepth=\"4\" ?> +<?rfc symrefs=\"yes\" ?> +<?rfc compact=\"yes\" ?> +<?rfc subcompact=\"no\" ?> +<rfc category=\"std\" ipr=\"pre5378Trust200902\" docName=\"FILLME.txt\"> + <front> +" + :title-format "<title abbrev=\"ABBREV HERE\">\n%s\n</title>\n" + :title-suffix "<author initials=\"A.A\" surname=\"LASTNAME\" fullname=\"FULL NAME\"> + <organization>Comany, Inc..</organization> + <address> + <postal> + <street></street> + <city></city> + <region></region> + <code></code> + <country></country> + </postal> + <phone></phone> + <email></email> + </address> + </author> + <date month=\"FILLMONTH\" year=\"FILLYEAR\"/> + <area>Operations and Management</area> + <workgroup>FIXME</workgroup> +<abstract>\n" + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + + :body-section-header-format "<section title=\"%s\">\n" + :body-section-suffix "</section>\n" + + ; if preformated text should be included (eg, : prefixed) + :body-line-export-preformated t + :body-line-fixed-prefix "<figure>\n<artwork>\n" + :body-line-fixed-suffix "\n</artwork>\n</figure>\n" + + ; other body lines + :body-line-format "%s" + :body-line-wrap 75 + + ; print above and below all body parts + :body-text-prefix "<t>\n" + :body-text-suffix "</t>\n" + + :body-list-prefix "<list style=\"symbols\">\n" + :body-list-suffix "</list>\n" + :body-list-format "<t>%s</t>\n" + + ) + ("trac-wiki" + :file-suffix ".txt" + :key-binding ?T + + ;; lifted from wikipedia exporter + :header-prefix "" + :header-suffix "" + + :title-format "= %s =\n" + + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + :body-section-prefix "\n" + + :body-section-header-prefix (" == " " === " " ==== " + " ===== " ) + :body-section-header-suffix (" ==\n\n" " ===\n\n" " ====\n\n" + " =====\n\n" " ======\n\n" " =======\n\n") + + :body-line-export-preformated t ;; yes/no/maybe??? + :body-line-format "%s\n" + :body-line-wrap 75 + + :body-line-fixed-format " %s\n" + + :body-list-format " * %s\n" + :body-number-list-format " # %s\n" + ;; :body-list-prefix "LISTSTART" + ;; :body-list-suffix "LISTEND" + + ;; this is ignored! [2010/02/02:rpg] + :body-bullet-list-prefix ("* " "** " "*** " "**** " "***** ") + ) + ("tikiwiki" + :file-suffix ".txt" + :key-binding ?U + + ;; lifted from wikipedia exporter + :header-prefix "" + :header-suffix "" + + :title-format "-= %s =-\n" + + :date-export nil + + :toc-export nil + + :body-header-section-numbers nil + :body-section-prefix "\n" + + :body-section-header-prefix ("! " "!! " "!!! " "!!!! " + "!!!!! " "!!!!!! " "!!!!!!! ") + :body-section-header-suffix (" \n" " \n" " \n" + " \n" " \n" " \n") + + + :body-line-export-preformated t ;; yes/no/maybe??? + :body-line-format "%s " + :body-line-wrap nil + + :body-line-fixed-format " %s\n" + + :body-list-format "* %s\n" + :body-number-list-format "# %s\n" + ;; :body-list-prefix "LISTSTART" + ;; :body-list-suffix "LISTEND" + :blockquote-start "\n^\n" + :blockquote-end "^\n\n" + :body-newline-paragraph "\n" + :bold-format "__%s__" + :italic-format "''%s''" + :underline-format "===%s===" + :strikethrough-format "--%s--" + :code-format "-+%s+-" + :verbatim-format "~pp~%s~/pp~" + ) + ) + "A assoc list of property lists to specify export definitions" +) + +(setq org-generic-export-type "demo") + +(defvar org-export-generic-section-type "") +(defvar org-export-generic-section-suffix "") + +;;;###autoload +(defun org-set-generic-type (type definition) + "Adds a TYPE and DEFINITION to the existing list of defined generic +export definitions." + (aput 'org-generic-alist type definition)) + +;;; helper functions for org-set-generic-type +(defvar org-export-generic-keywords nil) +(defmacro* def-org-export-generic-keyword (keyword + &key documentation + type) + "Define KEYWORD as a legitimate element for inclusion in +the body of an org-set-generic-type definition." + `(progn + (pushnew ,keyword org-export-generic-keywords) + ;; TODO: push the documentation and type information + ;; somewhere where it will do us some good. + )) + +(def-org-export-generic-keyword :body-newline-paragraph + :documentation "Bound either to NIL or to a pattern to be +inserted in the output for every blank line in the input. + The intention is to handle formats where text is flowed, and +newlines are interpreted as significant \(e.g., as indicating +preformatted text\). A common non-nil value for this keyword +is \"\\n\". Should typically be combined with a value for +:body-line-format that does NOT end with a newline." + :type string) + +;;; fontification keywords +(def-org-export-generic-keyword :bold-format) +(def-org-export-generic-keyword :italic-format) +(def-org-export-generic-keyword :underline-format) +(def-org-export-generic-keyword :strikethrough-format) +(def-org-export-generic-keyword :code-format) +(def-org-export-generic-keyword :verbatim-format) + + + + +(defun org-export-generic-remember-section (type suffix &optional prefix) + (setq org-export-generic-section-type type) + (setq org-export-generic-section-suffix suffix) + (if prefix + (insert prefix)) +) + +(defun org-export-generic-check-section (type &optional prefix suffix) + "checks to see if type is already in use, or we're switching parts +If we're switching, then insert a potentially previously remembered +suffix, and insert the current prefix immediately and then save the +suffix a later change time." + + (when (not (equal type org-export-generic-section-type)) + (if org-export-generic-section-suffix + (insert org-export-generic-section-suffix)) + (setq org-export-generic-section-type type) + (setq org-export-generic-section-suffix suffix) + (if prefix + (insert prefix)))) + +;;;###autoload +(defun org-export-generic (arg) + "Export the outline as generic output. +If there is an active region, export only the region. +The prefix ARG specifies how many levels of the outline should become +underlined headlines. The default is 3." + (interactive "P") + (setq-default org-todo-line-regexp org-todo-line-regexp) + (let* ((opt-plist (org-combine-plists (org-default-export-plist) + (org-infile-export-plist))) + (region-p (org-region-active-p)) + (rbeg (and region-p (region-beginning))) + (rend (and region-p (region-end))) + (subtree-p + (when region-p + (save-excursion + (goto-char rbeg) + (and (org-at-heading-p) + (>= (org-end-of-subtree t t) rend))))) + (level-offset (if subtree-p + (save-excursion + (goto-char rbeg) + (+ (funcall outline-level) + (if org-odd-levels-only 1 0))) + 0)) + (opt-plist (setq org-export-opt-plist + (if subtree-p + (org-export-add-subtree-options opt-plist rbeg) + opt-plist))) + + helpstart + (bogus (mapc (lambda (x) + (setq helpstart + (concat helpstart "\[" + (char-to-string + (plist-get (cdr x) :key-binding)) + "] " (car x) "\n"))) + org-generic-alist)) + + (help (concat helpstart " + +\[ ] the current setting of the org-generic-export-type variable +")) + + (cmds + + (append + (mapcar (lambda (x) + (list + (plist-get (cdr x) :key-binding) + (car x))) + org-generic-alist) + (list (list ? "default")))) + + r1 r2 ass + + ;; read in the type to use + (export-plist + (progn + (save-excursion + (save-window-excursion + (delete-other-windows) + (with-output-to-temp-buffer "*Org Export/Generic Styles Help*" + (princ help)) + (org-fit-window-to-buffer (get-buffer-window + "*Org Export/Generic Styles Help*")) + (message "Select command: ") + (setq r1 (read-char-exclusive)))) + (setq r2 (if (< r1 27) (+ r1 96) r1)) + (unless (setq ass (cadr (assq r2 cmds))) + (error "No command associated with key %c" r1)) + + (cdr (assoc + (if (equal ass "default") org-generic-export-type ass) + org-generic-alist)))) + + (custom-times org-display-custom-times) + (org-generic-current-indentation '(0 . 0)) + (level 0) (old-level 0) line txt lastwastext + (umax nil) + (umax-toc nil) + (case-fold-search nil) + (bfname (buffer-file-name (or (buffer-base-buffer) (current-buffer)))) + (filesuffix (or (plist-get export-plist :file-suffix) ".foo")) + (filename (concat (file-name-as-directory + (org-export-directory :ascii opt-plist)) + (file-name-sans-extension + (or (and subtree-p + (org-entry-get (region-beginning) + "EXPORT_FILE_NAME" t)) + (file-name-nondirectory bfname))) + filesuffix)) + (filename (if (equal (file-truename filename) + (file-truename bfname)) + (concat filename filesuffix) + filename)) + (buffer (find-file-noselect filename)) + (org-levels-open (make-vector org-level-max nil)) + (odd org-odd-levels-only) + (date (plist-get opt-plist :date)) + (author (plist-get opt-plist :author)) + (title (or (and subtree-p (org-export-get-title-from-subtree)) + (plist-get opt-plist :title) + (and (not + (plist-get opt-plist :skip-before-1st-heading)) + (org-export-grab-title-from-buffer)) + (file-name-sans-extension + (file-name-nondirectory bfname)))) + (email (plist-get opt-plist :email)) + (language (plist-get opt-plist :language)) + (quote-re0 (concat "^[ \t]*" org-quote-string "\\>")) +; (quote-re (concat "^\\(\\*+\\)\\([ \t]*" org-quote-string "\\>\\)")) + (todo nil) + (lang-words nil) + (region + (buffer-substring + (if (org-region-active-p) (region-beginning) (point-min)) + (if (org-region-active-p) (region-end) (point-max)))) + (org-export-current-backend 'org-export-generic) + (lines (org-split-string + (org-export-preprocess-string + region + :for-backend 'ascii + :skip-before-1st-heading + (plist-get opt-plist :skip-before-1st-heading) + :drawers (plist-get export-plist :drawers-export) + :tags (plist-get export-plist :tags-export) + :priority (plist-get export-plist :priority-export) + :footnotes (plist-get export-plist :footnotes-export) + :timestamps (plist-get export-plist :timestamps-export) + :todo-keywords (plist-get export-plist :todo-keywords-export) + :verbatim-multiline t + :select-tags (plist-get export-plist :select-tags-export) + :exclude-tags (plist-get export-plist :exclude-tags-export) + :emph-multiline t + :archived-trees + (plist-get export-plist :archived-trees-export) + :add-text (plist-get opt-plist :text)) + "\n")) + ;; export-generic plist variables + (withtags (plist-get export-plist :tags-export)) + (tagsintoc (plist-get export-plist :toc-tags-export)) + (tocnotagsstr (or (plist-get export-plist :toc-tags-none-string) "")) + (tocdepth (plist-get export-plist :toc-indent-depth)) + (tocindentchar (plist-get export-plist :toc-indent-char)) + (tocsecnums (plist-get export-plist :toc-section-numbers)) + (tocsecnumform (plist-get export-plist :toc-section-number-format)) + (tocformat (plist-get export-plist :toc-format)) + (tocformtodo (plist-get export-plist :toc-format-with-todo)) + (tocprefix (plist-get export-plist :toc-prefix)) + (tocsuffix (plist-get export-plist :toc-suffix)) + (bodyfixedpre (plist-get export-plist :body-line-fixed-prefix)) + (bodyfixedsuf (plist-get export-plist :body-line-fixed-suffix)) + (bodyfixedform (or (plist-get export-plist :body-line-fixed-format) + "%s")) + (listprefix (plist-get export-plist :body-list-prefix)) + (listsuffix (plist-get export-plist :body-list-suffix)) + (listformat (or (plist-get export-plist :body-list-format) "%s\n")) + (numlistleavenum + (plist-get export-plist :body-number-list-leave-number)) + (numlistprefix (plist-get export-plist :body-number-list-prefix)) + (numlistsuffix (plist-get export-plist :body-number-list-suffix)) + (numlistformat + (or (plist-get export-plist :body-number-list-format) "%s\n")) + (listchecktodo + (or (plist-get export-plist :body-list-checkbox-todo) "\\1")) + (listcheckdone + (or (plist-get export-plist :body-list-checkbox-done) "\\1")) + (listcheckhalf + (or (plist-get export-plist :body-list-checkbox-half) "\\1")) + (listchecktodoend + (or (plist-get export-plist :body-list-checkbox-todo-end) "")) + (listcheckdoneend + (or (plist-get export-plist :body-list-checkbox-done-end) "")) + (listcheckhalfend + (or (plist-get export-plist :body-list-checkbox-half-end) "")) + (bodytablestart + (or (plist-get export-plist :body-table-start) "")) + (bodytableend + (or (plist-get export-plist :body-table-end) "")) + (bodytablerowstart + (or (plist-get export-plist :body-table-row-start) "")) + (bodytablerowend + (or (plist-get export-plist :body-table-row-end) "")) + (bodytablecellstart + (or (plist-get export-plist :body-table-cell-start) "")) + (bodytablecellend + (or (plist-get export-plist :body-table-cell-end) "")) + (bodytablefirstcellstart + (or (plist-get export-plist :body-table-first-cell-start) "")) + (bodytableinteriorcellstart + (or (plist-get export-plist :body-table-interior-cell-start) "")) + (bodytableinteriorcellend + (or (plist-get export-plist :body-table-interior-cell-end) "")) + (bodytablelastcellend + (or (plist-get export-plist :body-table-last-cell-end) "")) + (bodytablehlinestart + (or (plist-get export-plist :body-table-hline-start) " \\1")) + (bodytablehlineend + (or (plist-get export-plist :body-table-hline-end) "")) + + + + (bodynewline-paragraph (plist-get export-plist :body-newline-paragraph)) + (bodytextpre (plist-get export-plist :body-text-prefix)) + (bodytextsuf (plist-get export-plist :body-text-suffix)) + (bodylinewrap (plist-get export-plist :body-line-wrap)) + (bodylineform (or (plist-get export-plist :body-line-format) "%s")) + (blockquotestart (or (plist-get export-plist :blockquote-start) "\n\n\t")) + (blockquoteend (or (plist-get export-plist :blockquote-end) "\n\n")) + + ;; dynamic variables used heinously in fontification + ;; not referenced locally... + (format-boldify (plist-get export-plist :bold-format)) + (format-italicize (plist-get export-plist :italic-format)) + (format-underline (plist-get export-plist :underline-format)) + (format-strikethrough (plist-get export-plist :strikethrough-format)) + (format-code (plist-get export-plist :code-format)) + (format-verbatim (plist-get export-plist :verbatim-format)) + + + + thetoc toctags have-headings first-heading-pos + table-open table-buffer link-buffer link desc desc0 rpl wrap) + + (let ((inhibit-read-only t)) + (org-unmodified + (remove-text-properties (point-min) (point-max) + '(:org-license-to-kill t)))) + + (setq org-min-level (org-get-min-level lines level-offset)) + (setq org-last-level org-min-level) + (org-init-section-numbers) + + (find-file-noselect filename) + + (setq lang-words (or (assoc language org-export-language-setup) + (assoc "en" org-export-language-setup))) + (switch-to-buffer-other-window buffer) + (erase-buffer) + (fundamental-mode) + ;; create local variables for all options, to make sure all called + ;; functions get the correct information + (mapc (lambda (x) + (set (make-local-variable (nth 2 x)) + (plist-get opt-plist (car x)))) + org-export-plist-vars) + (org-set-local 'org-odd-levels-only odd) + (setq umax (if arg (prefix-numeric-value arg) + org-export-headline-levels)) + (setq umax-toc umax) + + ;; File header + (if title + (insert + (org-export-generic-header title export-plist + :title-prefix + :title-format + :title-suffix))) + + (if (and (or author email) + (plist-get export-plist :author-export)) + (insert (concat (nth 1 lang-words) ": " (or author "") + (if email (concat " <" email ">") "") + "\n"))) + + (cond + ((and date (string-match "%" date)) + (setq date (format-time-string date))) + (date) + (t (setq date (format-time-string "%Y-%m-%d %T %Z")))) + + (if (and date (plist-get export-plist :date-export)) + (insert + (org-export-generic-header date export-plist + :date-prefix + :date-format + :date-suffix))) + + ;; export the table of contents first + (if (plist-get export-plist :toc-export) + (progn + (push + (org-export-generic-header (nth 3 lang-words) export-plist + :toc-header-prefix + :toc-header-format + :toc-header-suffix) + thetoc) + + (if tocprefix + (push tocprefix thetoc)) + + (mapc '(lambda (line) + (if (string-match org-todo-line-regexp line) + ;; This is a headline + (progn + (setq have-headings t) + (setq level (- (match-end 1) (match-beginning 1) + level-offset) + level (org-tr-level level) + txt (match-string 3 line) + todo + (or (and org-export-mark-todo-in-toc + (match-beginning 2) + (not (member (match-string 2 line) + org-done-keywords))) + ; TODO, not DONE + (and org-export-mark-todo-in-toc + (= level umax-toc) + (org-search-todo-below + line lines level)))) + (setq txt (org-html-expand-for-generic txt)) + + (while (string-match org-bracket-link-regexp txt) + (setq txt + (replace-match + (match-string (if (match-end 2) 3 1) txt) + t t txt))) + + (if (and (not tagsintoc) + (string-match + (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$") + txt)) + (setq txt (replace-match "" t t txt)) + ; include tags but formated + (if (string-match + (org-re "[ \t]+:\\([[:alnum:]_@:]+\\):[ \t]*$") + txt) + (progn + (setq + toctags + (org-export-generic-header + (match-string 1 txt) + export-plist :toc-tags-prefix + :toc-tags-format :toc-tags-suffix)) + (string-match + (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$") + txt) + (setq txt (replace-match "" t t txt))) + (setq toctags tocnotagsstr))) + + (if (string-match quote-re0 txt) + (setq txt (replace-match "" t t txt))) + + (if (<= level umax-toc) + (progn + (push + (concat + + (make-string + (* (max 0 (- level org-min-level)) tocdepth) + tocindentchar) + + (if tocsecnums + (format tocsecnumform + (org-section-number level)) + "") + + (format + (if todo tocformtodo tocformat) + txt) + + toctags) + + thetoc) + (setq org-last-level level)) + )))) + lines) + (if tocsuffix + (push tocsuffix thetoc)) + (setq thetoc (if have-headings (nreverse thetoc) nil)))) + + (org-init-section-numbers) + (org-export-generic-check-section "top") + (while (setq line (pop lines)) + (when (and link-buffer (string-match org-outline-regexp-bol line)) + (org-export-generic-push-links (nreverse link-buffer)) + (setq link-buffer nil)) + (setq wrap nil) + ;; Remove the quoted HTML tags. + ;; XXX + (setq line (org-html-expand-for-generic line)) + ;; Replace links with the description when possible + ;; XXX + (while (string-match org-bracket-link-regexp line) + (setq link (match-string 1 line) + desc0 (match-string 3 line) + desc (or desc0 (match-string 1 line))) + (if (and (> (length link) 8) + (equal (substring link 0 8) "coderef:")) + (setq line (replace-match + (format (org-export-get-coderef-format (substring link 8) desc) + (cdr (assoc + (substring link 8) + org-export-code-refs))) + t t line)) + (setq rpl (concat "[" + (or (match-string 3 line) (match-string 1 line)) + "]")) + (when (and desc0 (not (equal desc0 link))) + (if org-export-generic-links-to-notes + (push (cons desc0 link) link-buffer) + (setq rpl (concat rpl " (" link ")") + wrap (+ (length line) (- (length (match-string 0 line))) + (length desc))))) + (setq line (replace-match rpl t t line)))) + (when custom-times + (setq line (org-translate-time line))) + (cond + ((string-match "^\\(\\*+\\)[ \t]+\\(.*\\)" line) + ;; + ;; a Headline + ;; + (org-export-generic-check-section "headline") + + (setq first-heading-pos (or first-heading-pos (point))) + (setq level (org-tr-level (- (match-end 1) (match-beginning 1) + level-offset)) + txt (match-string 2 line)) + (org-generic-level-start level old-level txt umax export-plist lines) + (setq old-level level)) + + ((and org-export-with-tables + (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" line)) + ;; + ;; a Table + ;; + (org-export-generic-check-section "table") + + (if (not table-open) + ;; New table starts + (setq table-open t table-buffer nil)) + ;; Accumulate table lines + (setq table-buffer (cons line table-buffer)) + (when (or (not lines) + (not (string-match "^\\([ \t]*\\)\\(|\\|\\+-+\\+\\)" + (car lines)))) + (setq table-open nil + table-buffer (nreverse table-buffer)) + (insert (mapconcat + (lambda (x) + (org-fix-indentation x org-generic-current-indentation)) + (org-format-table-generic table-buffer) + "\n") "\n"))) + + ((string-match "^\\([ \t]*\\)\\(:\\( \\|$\\)\\)" line) + ;; + ;; pre-formatted text + ;; + (setq line (replace-match "\\1" nil nil line)) + + (org-export-generic-check-section "preformat" bodyfixedpre bodyfixedsuf) + + (insert (format bodyfixedform line))) + + ((or (string-match "^\\([ \t]*\\)\\([\-\+][ \t]*\\)" line) + ;; if the bullet list item is an asterisk, the leading space is /mandatory/ + ;; [2010/02/02:rpg] + (string-match "^\\([ \t]+\\)\\(\\*[ \t]*\\)" line)) + ;; + ;; plain list item + ;; TODO: nested lists + ;; + ;; first add a line break between any previous paragraph or line item and this + ;; one + (when bodynewline-paragraph + (insert bodynewline-paragraph)) + + ;; I believe this gets rid of leading whitespace. + (setq line (replace-match "" nil nil line)) + + ;; won't this insert the suffix /before/ the last line of the list? + ;; also isn't it spoofed by bulleted lists that have a line skip between the list items + ;; unless 'org-empty-line-terminates-plain-lists' is true? + (org-export-generic-check-section "liststart" listprefix listsuffix) + + ;; deal with checkboxes + (cond + ((string-match "^\\(\\[ \\]\\)[ \t]*" line) + (setq line (concat (replace-match listchecktodo nil nil line) + listchecktodoend))) + ((string-match "^\\(\\[X\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckdone nil nil line) + listcheckdoneend))) + ((string-match "^\\(\\[/\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckhalf nil nil line) + listcheckhalfend))) + ) + + (insert (format listformat (org-export-generic-fontify line)))) + ((string-match "^\\([ \t]+\\)\\([0-9]+\\.[ \t]*\\)" line) + ;; + ;; numbered list item + ;; + ;; TODO: nested lists + ;; + (setq line (replace-match (if numlistleavenum "\\2" "") nil nil line)) + + (org-export-generic-check-section "numliststart" + numlistprefix numlistsuffix) + + ;; deal with checkboxes + ;; TODO: whoops; leaving the numbers is a problem for ^ matching + (cond + ((string-match "\\(\\[ \\]\\)[ \t]*" line) + (setq line (concat (replace-match listchecktodo nil nil line) + listchecktodoend))) + ((string-match "\\(\\[X\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckdone nil nil line) + listcheckdoneend))) + ((string-match "\\(\\[/\\]\\)[ \t]*" line) + (setq line (concat (replace-match listcheckhalf nil nil line) + listcheckhalfend))) + ) + + (insert (format numlistformat (org-export-generic-fontify line)))) + + ((equal line "ORG-BLOCKQUOTE-START") + (setq line blockquotestart)) + ((equal line "ORG-BLOCKQUOTE-END") + (setq line blockquoteend)) + ((string-match "^\\s-*$" line) + ;; blank line + (if bodynewline-paragraph + (insert bodynewline-paragraph))) + (t + ;; + ;; body + ;; + (org-export-generic-check-section "body" bodytextpre bodytextsuf) + + (setq line + (org-export-generic-fontify line)) + + ;; XXX: properties? list? + (if (string-match "^\\([ \t]*\\)\\([-+*][ \t]+\\)\\(.*?\\)\\( ::\\)" line) + (setq line (replace-match "\\1\\3:" t nil line))) + + (setq line (org-fix-indentation line org-generic-current-indentation)) + + ;; Remove forced line breaks + (if (string-match "\\\\\\\\[ \t]*$" line) + (setq line (replace-match "" t t line))) + + (if bodylinewrap + ;; XXX: was dependent on wrap var which was calculated by??? + (if (> (length line) bodylinewrap) + (setq line + (org-export-generic-wrap line bodylinewrap)) + (setq line line))) + (insert (format bodylineform line))))) + + ;; if we're at a level > 0; insert the closing body level stuff + (let ((counter 0)) + (while (> (- level counter) 0) + (insert + (org-export-generic-format export-plist :body-section-suffix 0 + (- level counter))) + (setq counter (1+ counter)))) + + (org-export-generic-check-section "bottom") + + (org-export-generic-push-links (nreverse link-buffer)) + + (normal-mode) + + ;; insert the table of contents + (when thetoc + (goto-char (point-min)) + (if (re-search-forward "^[ \t]*\\[TABLE-OF-CONTENTS\\][ \t]*$" nil t) + (progn + (goto-char (match-beginning 0)) + (replace-match "")) + (goto-char first-heading-pos)) + (mapc 'insert thetoc) + (or (looking-at "[ \t]*\n[ \t]*\n") + (insert "\n\n"))) + + ;; Convert whitespace place holders + (goto-char (point-min)) + (let (beg end) + (while (setq beg (next-single-property-change (point) 'org-whitespace)) + (setq end (next-single-property-change beg 'org-whitespace)) + (goto-char beg) + (delete-region beg end) + (insert (make-string (- end beg) ?\ )))) + + (save-buffer) + + ;; remove display and invisible chars + (let (beg end) + (goto-char (point-min)) + (while (setq beg (next-single-property-change (point) 'display)) + (setq end (next-single-property-change beg 'display)) + (delete-region beg end) + (goto-char beg) + (insert "=>")) + (goto-char (point-min)) + (while (setq beg (next-single-property-change (point) 'org-cwidth)) + (setq end (next-single-property-change beg 'org-cwidth)) + (delete-region beg end) + (goto-char beg))) + (goto-char (point-min)))) + + +(defun org-export-generic-format (export-plist prop &optional len n reverse) + "converts a property specification to a string given types of properties + +The EXPORT-PLIST should be defined as the lookup plist. +The PROP should be the property name to search for in it. +LEN is set to the length of multi-characters strings to generate (or 0) +N is the tree depth +REVERSE means to reverse the list if the plist match is a list + " + (let* ((prefixtype (plist-get export-plist prop)) + subtype) + (cond + ((null prefixtype) "") + ((and len (char-or-string-p prefixtype) (not (stringp prefixtype))) + ;; sequence of chars + (concat (make-string len prefixtype) "\n")) + ((stringp prefixtype) + prefixtype) + ((and n (listp prefixtype)) + (if reverse + (setq prefixtype (reverse prefixtype))) + (setq subtype (if (> n (length prefixtype)) + (car (last prefixtype)) + (nth (1- n) prefixtype))) + (if (stringp subtype) + subtype + (concat (make-string len subtype) "\n"))) + (t "")) + )) + +(defun org-export-generic-header (header export-plist + prefixprop formatprop postfixprop + &optional n reverse) + "convert a header to an output string given formatting property names" + (let* ((formatspec (plist-get export-plist formatprop)) + (len (length header))) + (concat + (org-export-generic-format export-plist prefixprop len n reverse) + (format (or formatspec "%s") header) + (org-export-generic-format export-plist postfixprop len n reverse)) + )) + +(defun org-export-generic-preprocess (parameters) + "Do extra work for ASCII export" + ;; Put quotes around verbatim text + (goto-char (point-min)) + (while (re-search-forward org-verbatim-re nil t) + (goto-char (match-end 2)) + (backward-delete-char 1) (insert "'") + (goto-char (match-beginning 2)) + (delete-char 1) (insert "`") + (goto-char (match-end 2))) + ;; Remove target markers + (goto-char (point-min)) + (while (re-search-forward "<<<?\\([^<>]*\\)>>>?\\([ \t]*\\)" nil t) + (replace-match "\\1\\2"))) + +(defun org-html-expand-for-generic (line) + "Handle quoted HTML for ASCII export." + (if org-export-html-expand + (while (string-match "@<[^<>\n]*>" line) + ;; We just remove the tags for now. + (setq line (replace-match "" nil nil line)))) + line) + +(defun org-export-generic-wrap (line where) + "Wrap LINE at or before WHERE." + (let* ((ind (org-get-indentation line)) + (indstr (make-string ind ?\ )) + (len (length line)) + (result "") + pos didfirst) + (while (> len where) + (catch 'found + (loop for i from where downto (/ where 2) do + (and (equal (aref line i) ?\ ) + (setq pos i) + (throw 'found t)))) + (if pos + (progn + (setq result + (concat result + (if didfirst indstr "") + (substring line 0 pos) + "\n")) + (setq didfirst t) + (setq line (substring line (1+ pos))) + (setq len (length line))) + (setq result (concat result line)) + (setq len 0))) + (concat result indstr line))) + +(defun org-export-generic-push-links (link-buffer) + "Push out links in the buffer." + (when link-buffer + ;; We still have links to push out. + (insert "\n") + (let ((ind "")) + (save-match-data + (if (save-excursion + (re-search-backward + "^\\(\\([ \t]*\\)\\|\\(\\*+ \\)\\)[^ \t\n]" nil t)) + (setq ind (or (match-string 2) + (make-string (length (match-string 3)) ?\ ))))) + (mapc (lambda (x) (insert ind "[" (car x) "]: " (cdr x) "\n")) + link-buffer)) + (insert "\n"))) + +(defun org-generic-level-start (level old-level title umax export-plist + &optional lines) + "Insert a new level in a generic export." + (let ((n (- level umax 1)) + (ind 0) + (diff (- level old-level)) (counter 0) + (secnums (plist-get export-plist :body-header-section-numbers)) + (secnumformat + (plist-get export-plist :body-header-section-number-format)) + char tagstring) + (unless org-export-with-tags + (if (string-match (org-re "[ \t]+\\(:[[:alnum:]_@:]+:\\)[ \t]*$") title) + (setq title (replace-match "" t t title)))) + + (cond + ;; going deeper + ((> level old-level) + (while (< (+ old-level counter) (1- level)) + (insert + (org-export-generic-format export-plist :body-section-prefix 0 + (+ old-level counter))) + (setq counter (1+ counter)) + )) + ;; going up + ((< level old-level) + (while (> (- old-level counter) (1- level)) + (insert + (org-export-generic-format export-plist :body-section-suffix 0 + (- old-level counter))) + (setq counter (1+ counter)) + )) + ;; same level + ((= level old-level) + (insert + (org-export-generic-format export-plist :body-section-suffix 0 level)) + ) + ) + (insert + (org-export-generic-format export-plist :body-section-prefix 0 level)) + + (if (and org-export-with-section-numbers + secnums + (or (not (numberp secnums)) + (< level secnums))) + (setq title + (concat (format (or secnumformat "%s ") + (org-section-number level)) title))) + + ;; handle tags and formatting + (if (string-match + (org-re "[ \t]+:\\([[:alnum:]_@:]+\\):[ \t]*$") title) + (progn + (if (plist-get export-plist :body-tags-export) + (setq tagstring (org-export-generic-header (match-string 1 title) + export-plist + :body-tags-prefix + :body-tags-format + :body-tags-suffix))) + (string-match (org-re "[ \t]+:[[:alnum:]_@:]+:[ \t]*$") title) + (setq title (replace-match "" t t title))) + (setq tagstring (plist-get export-plist :body-tags-none-string))) + + (insert + (org-export-generic-header title export-plist + :body-section-header-prefix + :body-section-header-format + :body-section-header-suffix + level)) + (if tagstring + (insert tagstring)) + + (setq org-generic-current-indentation '(0 . 0)))) + +(defun org-insert-centered (s &optional underline) + "Insert the string S centered and underline it with character UNDERLINE." + (let ((ind (max (/ (- fill-column (string-width s)) 2) 0))) + (insert (make-string ind ?\ ) s "\n") + (if underline + (insert (make-string ind ?\ ) + (make-string (string-width s) underline) + "\n")))) + +(defvar org-table-colgroup-info nil) +(defun org-format-table-generic (lines) + "Format a table for ascii export." + (if (stringp lines) + (setq lines (org-split-string lines "\n"))) + (if (not (string-match "^[ \t]*|" (car lines))) + ;; Table made by table.el - test for spanning + lines + + ;; A normal org table + ;; Get rid of hlines at beginning and end + (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) + (setq lines (nreverse lines)) + (if (string-match "^[ \t]*|-" (car lines)) (setq lines (cdr lines))) + (setq lines (nreverse lines)) + (when org-export-table-remove-special-lines + ;; Check if the table has a marking column. If yes remove the + ;; column and the special lines + (setq lines (org-table-clean-before-export lines))) + ;; Get rid of the vertical lines except for grouping + (let ((vl (org-colgroup-info-to-vline-list org-table-colgroup-info)) + (rtn (list bodytablestart)) line vl1 start) + (while (setq line (pop lines)) + (setq line (concat bodytablerowstart line)) + (if (string-match org-table-hline-regexp line) + (and (string-match "|\\(.*\\)|" line) + (setq line (replace-match (concat bodytablehlinestart bodytablehlineend) t nil line))) + (setq start 0 vl1 vl) + (if (string-match "|\\(.*\\)|" line) + (setq line (replace-match (concat bodytablefirstcellstart bodytablecellstart " \\1 " bodytablecellend bodytablelastcellend) t nil line))) + (while (string-match "|" line start) + (setq start (+ (match-end 0) (length (concat bodytablecellend bodytableinteriorcellend bodytableinteriorcellstart bodytablecellstart)))) + (or (pop vl1) (setq line (replace-match (concat bodytablecellend bodytableinteriorcellend bodytableinteriorcellstart bodytablecellstart) t t line))))) + (setq line (concat line bodytablerowend)) + (push line rtn)) + (setq rtn (cons bodytableend rtn)) + (nreverse rtn)))) + +(defun org-colgroup-info-to-vline-list (info) + (let (vl new last) + (while info + (setq last new new (pop info)) + (if (or (memq last '(:end :startend)) + (memq new '(:start :startend))) + (push t vl) + (push nil vl))) + (setq vl (nreverse vl)) + (and vl (setcar vl nil)) + vl)) + + +;;; FIXME: this should probably turn into a defconstant later [2010/05/20:rpg] +(defvar org-export-generic-emphasis-alist + '(("*" format-boldify nil) + ("/" format-italicize nil) + ("_" format-underline nil) + ("+" format-strikethrough nil) + ("=" format-code t) + ("~" format-verbatim t)) + "Alist of org format -> formatting variables for fontification. +Each element of the list is a list of three elements. +The first element is the character used as a marker for fontification. +The second element is a variable name, set in org-export-generic. That +variable will be dereferenced to obtain a formatting string to wrap +fontified text with. +The third element decides whether to protect converted text from other +conversions.") + +;;; Cargo-culted from the latex translation. I couldn't figure out how +;;; to keep the structure since the generic export operates on lines, rather +;;; than on a buffer as in the latex export, meaning that none of the +;;; search forward code could be kept. This led me to rewrite the +;;; whole thing recursively. A huge lose for efficiency (potentially), +;;; but I couldn't figure out how to make the looping work. +;;; Worse, it's /doubly/ recursive, because this function calls +;;; org-export-generic-emph-format, which can call it recursively... +;;; [2010/05/20:rpg] +(defun org-export-generic-fontify (string) + "Convert fontification according to generic rules." + (if (string-match org-emph-re string) + ;; The match goes one char after the *string*, except at the end of a line + (let ((emph (assoc (match-string 3 string) + org-export-generic-emphasis-alist)) + (beg (match-beginning 0)) + (end (match-end 0))) + (unless emph + (message "`org-export-generic-emphasis-alist' has no entry for formatting triggered by \"%s\"" + (match-string 3 string))) + ;; now we need to determine whether we have strikethrough or + ;; a list, which is a bit nasty + (if (and (equal (match-string 3 string) "+") + (save-match-data + (string-match "\\`-+\\'" (match-string 4 string)))) + ;; a list --- skip this match and recurse on the point after the + ;; first emph char... + (concat (substring string 0 (1+ (match-beginning 3))) + (org-export-generic-fontify (substring string (match-beginning 3)))) + (concat (substring string 0 beg) ;; part before the match + (match-string 1 string) + (org-export-generic-emph-format (second emph) + (match-string 4 string) + (third emph)) + (or (match-string 5 string) "") + (org-export-generic-fontify (substring string end))))) + string)) + +(defun org-export-generic-emph-format (format-varname string protect) + "Return a string that results from applying the markup indicated by +FORMAT-VARNAME to STRING." + (let ((format (symbol-value format-varname))) + (let ((string-to-emphasize + (if protect + string + (org-export-generic-fontify string)))) + (if format + (format format string-to-emphasize) + string-to-emphasize)))) + +(provide 'org-generic) +(provide 'org-export-generic) + +;;; org-export-generic.el ends here diff --git a/contrib/lisp/org-export.el b/contrib/lisp/org-export.el new file mode 100644 index 0000000..4f01b7e --- /dev/null +++ b/contrib/lisp/org-export.el @@ -0,0 +1,4518 @@ +;;; org-export.el --- Generic Export Engine For Org + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou <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 generic export engine for Org, built on +;; its syntactical parser: Org Elements. +;; +;; Besides that parser, the generic exporter is made of three distinct +;; parts: +;; +;; - The communication channel consists in a property list, which is +;; created and updated during the process. Its use is to offer +;; every piece of information, would it be about initial environment +;; or contextual data, all in a single place. The exhaustive list +;; of properties is given in "The Communication Channel" section of +;; this file. +;; +;; - The transcoder walks the parse tree, ignores or treat as plain +;; text elements and objects according to export options, and +;; eventually calls back-end specific functions to do the real +;; transcoding, concatenating their return value along the way. +;; +;; - The filter system is activated at the very beginning and the very +;; end of the export process, and each time an element or an object +;; has been converted. It is the entry point to fine-tune standard +;; output from back-end transcoders. See "The Filter System" +;; section for more information. +;; +;; The core function is `org-export-as'. It returns the transcoded +;; buffer as a string. +;; +;; An export back-end is defined with `org-export-define-backend', +;; which sets one mandatory variable: his translation table. Its name +;; is always `org-BACKEND-translate-alist' where BACKEND stands for +;; the name chosen for the back-end. Its value is an alist whose keys +;; are elements and objects types and values translator functions. +;; See function's docstring for more information about translators. +;; +;; Optionally, `org-export-define-backend' can also support specific +;; buffer keywords, OPTION keyword's items and filters. Also refer to +;; function documentation for more information. +;; +;; If the new back-end shares most properties with another one, +;; `org-export-define-derived-backend' can be used to simplify the +;; process. +;; +;; Any back-end can define its own variables. Among them, those +;; customizable should belong to the `org-export-BACKEND' group. +;; +;; Tools for common tasks across back-ends are implemented in the +;; penultimate part of this file. A dispatcher for standard back-ends +;; is provided in the last one. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org-element) + + +(declare-function org-e-ascii-export-as-ascii "org-e-ascii" + (&optional subtreep visible-only body-only ext-plist)) +(declare-function org-e-ascii-export-to-ascii "org-e-ascii" + (&optional subtreep visible-only body-only ext-plist pub-dir)) +(declare-function org-e-html-export-as-html "org-e-html" + (&optional subtreep visible-only body-only ext-plist)) +(declare-function org-e-html-export-to-html "org-e-html" + (&optional subtreep visible-only body-only ext-plist pub-dir)) +(declare-function org-e-latex-export-as-latex "org-e-latex" + (&optional subtreep visible-only body-only ext-plist)) +(declare-function org-e-latex-export-to-latex "org-e-latex" + (&optional subtreep visible-only body-only ext-plist pub-dir)) +(declare-function org-e-latex-export-to-pdf "org-e-latex" + (&optional subtreep visible-only body-only ext-plist pub-dir)) +(declare-function org-e-odt-export-to-odt "org-e-odt" + (&optional subtreep visible-only body-only ext-plist pub-dir)) +(declare-function org-e-publish "org-e-publish" (project &optional force)) +(declare-function org-e-publish-all "org-e-publish" (&optional force)) +(declare-function org-e-publish-current-file "org-e-publish" (&optional force)) +(declare-function org-e-publish-current-project "org-e-publish" + (&optional force)) +(declare-function org-export-blocks-preprocess "org-exp-blocks") + +(defvar org-e-publish-project-alist) +(defvar org-table-number-fraction) +(defvar org-table-number-regexp) + + + +;;; Internal Variables +;; +;; Among internal variables, the most important is +;; `org-export-options-alist'. This variable define the global export +;; options, shared between every exporter, and how they are acquired. + +(defconst org-export-max-depth 19 + "Maximum nesting depth for headlines, counting from 0.") + +(defconst org-export-options-alist + '((:author "AUTHOR" nil user-full-name t) + (:creator "CREATOR" nil org-export-creator-string) + (:date "DATE" nil nil t) + (:description "DESCRIPTION" nil nil newline) + (:email "EMAIL" nil user-mail-address t) + (:exclude-tags "EXCLUDE_TAGS" nil org-export-exclude-tags split) + (:headline-levels nil "H" org-export-headline-levels) + (:keywords "KEYWORDS" nil nil space) + (:language "LANGUAGE" nil org-export-default-language t) + (:preserve-breaks nil "\\n" org-export-preserve-breaks) + (:section-numbers nil "num" org-export-with-section-numbers) + (:select-tags "SELECT_TAGS" nil org-export-select-tags split) + (:time-stamp-file nil "timestamp" org-export-time-stamp-file) + (:title "TITLE" nil nil space) + (:with-archived-trees nil "arch" org-export-with-archived-trees) + (:with-author nil "author" org-export-with-author) + (:with-clocks nil "c" org-export-with-clocks) + (:with-creator nil "creator" org-export-with-creator) + (:with-drawers nil "d" org-export-with-drawers) + (:with-email nil "email" org-export-with-email) + (:with-emphasize nil "*" org-export-with-emphasize) + (:with-entities nil "e" org-export-with-entities) + (:with-fixed-width nil ":" org-export-with-fixed-width) + (:with-footnotes nil "f" org-export-with-footnotes) + (:with-inlinetasks nil "inline" org-export-with-inlinetasks) + (:with-plannings nil "p" org-export-with-planning) + (:with-priority nil "pri" org-export-with-priority) + (:with-special-strings nil "-" org-export-with-special-strings) + (:with-sub-superscript nil "^" org-export-with-sub-superscripts) + (:with-toc nil "toc" org-export-with-toc) + (:with-tables nil "|" org-export-with-tables) + (:with-tags nil "tags" org-export-with-tags) + (:with-tasks nil "tasks" org-export-with-tasks) + (:with-timestamps nil "<" org-export-with-timestamps) + (:with-todo-keywords nil "todo" org-export-with-todo-keywords)) + "Alist between export properties and ways to set them. + +The CAR of the alist is the property name, and the CDR is a list +like (KEYWORD OPTION DEFAULT BEHAVIOUR) where: + +KEYWORD is a string representing a buffer keyword, or nil. Each + property defined this way can also be set, during subtree + export, through an headline property named after the keyword + with the \"EXPORT_\" prefix (i.e. DATE keyword and EXPORT_DATE + property). +OPTION is a string that could be found in an #+OPTIONS: line. +DEFAULT is the default value for the property. +BEHAVIOUR determine how Org should handle multiple keywords for + the same property. It is a symbol among: + nil Keep old value and discard the new one. + t Replace old value with the new one. + `space' Concatenate the values, separating them with a space. + `newline' Concatenate the values, separating them with + a newline. + `split' Split values at white spaces, and cons them to the + previous list. + +KEYWORD and OPTION have precedence over DEFAULT. + +All these properties should be back-end agnostic. Back-end +specific properties are set through `org-export-define-backend'. +Properties redefined there have precedence over these.") + +(defconst org-export-special-keywords + '("SETUP_FILE" "OPTIONS" "MACRO") + "List of in-buffer keywords that require special treatment. +These keywords are not directly associated to a property. The +way they are handled must be hard-coded into +`org-export--get-inbuffer-options' function.") + +(defconst org-export-filters-alist + '((:filter-bold . org-export-filter-bold-functions) + (:filter-babel-call . org-export-filter-babel-call-functions) + (:filter-center-block . org-export-filter-center-block-functions) + (:filter-clock . org-export-filter-clock-functions) + (:filter-code . org-export-filter-code-functions) + (:filter-comment . org-export-filter-comment-functions) + (:filter-comment-block . org-export-filter-comment-block-functions) + (:filter-drawer . org-export-filter-drawer-functions) + (:filter-dynamic-block . org-export-filter-dynamic-block-functions) + (:filter-entity . org-export-filter-entity-functions) + (:filter-example-block . org-export-filter-example-block-functions) + (:filter-export-block . org-export-filter-export-block-functions) + (:filter-export-snippet . org-export-filter-export-snippet-functions) + (:filter-final-output . org-export-filter-final-output-functions) + (:filter-fixed-width . org-export-filter-fixed-width-functions) + (:filter-footnote-definition . org-export-filter-footnote-definition-functions) + (:filter-footnote-reference . org-export-filter-footnote-reference-functions) + (:filter-headline . org-export-filter-headline-functions) + (:filter-horizontal-rule . org-export-filter-horizontal-rule-functions) + (:filter-inline-babel-call . org-export-filter-inline-babel-call-functions) + (:filter-inline-src-block . org-export-filter-inline-src-block-functions) + (:filter-inlinetask . org-export-filter-inlinetask-functions) + (:filter-italic . org-export-filter-italic-functions) + (:filter-item . org-export-filter-item-functions) + (:filter-keyword . org-export-filter-keyword-functions) + (:filter-latex-environment . org-export-filter-latex-environment-functions) + (:filter-latex-fragment . org-export-filter-latex-fragment-functions) + (:filter-line-break . org-export-filter-line-break-functions) + (:filter-link . org-export-filter-link-functions) + (:filter-macro . org-export-filter-macro-functions) + (:filter-paragraph . org-export-filter-paragraph-functions) + (:filter-parse-tree . org-export-filter-parse-tree-functions) + (:filter-plain-list . org-export-filter-plain-list-functions) + (:filter-plain-text . org-export-filter-plain-text-functions) + (:filter-planning . org-export-filter-planning-functions) + (:filter-property-drawer . org-export-filter-property-drawer-functions) + (:filter-quote-block . org-export-filter-quote-block-functions) + (:filter-quote-section . org-export-filter-quote-section-functions) + (:filter-radio-target . org-export-filter-radio-target-functions) + (:filter-section . org-export-filter-section-functions) + (:filter-special-block . org-export-filter-special-block-functions) + (:filter-src-block . org-export-filter-src-block-functions) + (:filter-statistics-cookie . org-export-filter-statistics-cookie-functions) + (:filter-strike-through . org-export-filter-strike-through-functions) + (:filter-subscript . org-export-filter-subscript-functions) + (:filter-superscript . org-export-filter-superscript-functions) + (:filter-table . org-export-filter-table-functions) + (:filter-table-cell . org-export-filter-table-cell-functions) + (:filter-table-row . org-export-filter-table-row-functions) + (:filter-target . org-export-filter-target-functions) + (:filter-timestamp . org-export-filter-timestamp-functions) + (:filter-underline . org-export-filter-underline-functions) + (:filter-verbatim . org-export-filter-verbatim-functions) + (:filter-verse-block . org-export-filter-verse-block-functions)) + "Alist between filters properties and initial values. + +The key of each association is a property name accessible through +the communication channel. Its value is a configurable global +variable defining initial filters. + +This list is meant to install user specified filters. Back-end +developers may install their own filters using +`org-export-define-backend'. Filters defined there will always +be prepended to the current list, so they always get applied +first.") + +(defconst org-export-default-inline-image-rule + `(("file" . + ,(format "\\.%s\\'" + (regexp-opt + '("png" "jpeg" "jpg" "gif" "tiff" "tif" "xbm" + "xpm" "pbm" "pgm" "ppm") t)))) + "Default rule for link matching an inline image. +This rule applies to links with no description. By default, it +will be considered as an inline image if it targets a local file +whose extension is either \"png\", \"jpeg\", \"jpg\", \"gif\", +\"tiff\", \"tif\", \"xbm\", \"xpm\", \"pbm\", \"pgm\" or \"ppm\". +See `org-export-inline-image-p' for more information about +rules.") + + + +;;; User-configurable Variables +;; +;; Configuration for the masses. +;; +;; They should never be accessed directly, as their value is to be +;; stored in a property list (cf. `org-export-options-alist'). +;; Back-ends will read their value from there instead. + +(defgroup org-export nil + "Options for exporting Org mode files." + :tag "Org Export" + :group 'org) + +(defgroup org-export-general nil + "General options for export engine." + :tag "Org Export General" + :group 'org-export) + +(defcustom org-export-with-archived-trees 'headline + "Whether sub-trees with the ARCHIVE tag should be exported. + +This can have three different values: +nil Do not export, pretend this tree is not present. +t Do export the entire tree. +`headline' Only export the headline, but skip the tree below it. + +This option can also be set with the #+OPTIONS line, +e.g. \"arch:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "Not at all" nil) + (const :tag "Headline only" 'headline) + (const :tag "Entirely" t))) + +(defcustom org-export-with-author t + "Non-nil means insert author name into the exported file. +This option can also be set with the #+OPTIONS line, +e.g. \"author:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-clocks nil + "Non-nil means export CLOCK keywords. +This option can also be set with the #+OPTIONS line, +e.g. \"c:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-creator 'comment + "Non-nil means the postamble should contain a creator sentence. + +The sentence can be set in `org-export-creator-string' and +defaults to \"Generated by Org mode XX in Emacs XXX.\". + +If the value is `comment' insert it as a comment." + :group 'org-export-general + :type '(choice + (const :tag "No creator sentence" nil) + (const :tag "Sentence as a comment" 'comment) + (const :tag "Insert the sentence" t))) + +(defcustom org-export-creator-string + (format "Generated by Org mode %s in Emacs %s." + (if (fboundp 'org-version) (org-version) "(Unknown)") + emacs-version) + "String to insert at the end of the generated document." + :group 'org-export-general + :type '(string :tag "Creator string")) + +(defcustom org-export-with-drawers t + "Non-nil means export contents of standard drawers. + +When t, all drawers are exported. This may also be a list of +drawer names to export. This variable doesn't apply to +properties drawers. + +This option can also be set with the #+OPTIONS line, +e.g. \"d:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "All drawers" t) + (const :tag "None" nil) + (repeat :tag "Selected drawers" + (string :tag "Drawer name")))) + +(defcustom org-export-with-email nil + "Non-nil means insert author email into the exported file. +This option can also be set with the #+OPTIONS line, +e.g. \"email:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-emphasize t + "Non-nil means interpret *word*, /word/, and _word_ as emphasized text. + +If the export target supports emphasizing text, the word will be +typeset in bold, italic, or underlined, respectively. Not all +export backends support this. + +This option can also be set with the #+OPTIONS line, e.g. \"*:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-exclude-tags '("noexport") + "Tags that exclude a tree from export. + +All trees carrying any of these tags will be excluded from +export. This is without condition, so even subtrees inside that +carry one of the `org-export-select-tags' will be removed. + +This option can also be set with the #+EXCLUDE_TAGS: keyword." + :group 'org-export-general + :type '(repeat (string :tag "Tag"))) + +(defcustom org-export-with-fixed-width t + "Non-nil means lines starting with \":\" will be in fixed width font. + +This can be used to have pre-formatted text, fragments of code +etc. For example: + : ;; Some Lisp examples + : (while (defc cnt) + : (ding)) +will be looking just like this in also HTML. See also the QUOTE +keyword. Not all export backends support this. + +This option can also be set with the #+OPTIONS line, e.g. \"::nil\"." + :group 'org-export-translation + :type 'boolean) + +(defcustom org-export-with-footnotes t + "Non-nil means Org footnotes should be exported. +This option can also be set with the #+OPTIONS line, +e.g. \"f:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-headline-levels 3 + "The last level which is still exported as a headline. + +Inferior levels will produce itemize lists when exported. + +This option can also be set with the #+OPTIONS line, e.g. \"H:2\"." + :group 'org-export-general + :type 'integer) + +(defcustom org-export-default-language "en" + "The default language for export and clocktable translations, as a string. +This may have an association in +`org-clock-clocktable-language-setup'." + :group 'org-export-general + :type '(string :tag "Language")) + +(defcustom org-export-preserve-breaks nil + "Non-nil means preserve all line breaks when exporting. + +Normally, in HTML output paragraphs will be reformatted. + +This option can also be set with the #+OPTIONS line, +e.g. \"\\n:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-entities t + "Non-nil means interpret entities when exporting. + +For example, HTML export converts \\alpha to α and \\AA to +Å. + +For a list of supported names, see the constant `org-entities' +and the user option `org-entities-user'. + +This option can also be set with the #+OPTIONS line, +e.g. \"e:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-inlinetasks t + "Non-nil means inlinetasks should be exported. +This option can also be set with the #+OPTIONS line, +e.g. \"inline:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-planning nil + "Non-nil means include planning info in export. +This option can also be set with the #+OPTIONS: line, +e.g. \"p:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-priority nil + "Non-nil means include priority cookies in export. +This option can also be set with the #+OPTIONS line, +e.g. \"pri:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-section-numbers t + "Non-nil means add section numbers to headlines when exporting. + +When set to an integer n, numbering will only happen for +headlines whose relative level is higher or equal to n. + +This option can also be set with the #+OPTIONS line, +e.g. \"num:t\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-select-tags '("export") + "Tags that select a tree for export. + +If any such tag is found in a buffer, all trees that do not carry +one of these tags will be ignored during export. Inside trees +that are selected like this, you can still deselect a subtree by +tagging it with one of the `org-export-exclude-tags'. + +This option can also be set with the #+SELECT_TAGS: keyword." + :group 'org-export-general + :type '(repeat (string :tag "Tag"))) + +(defcustom org-export-with-special-strings t + "Non-nil means interpret \"\-\", \"--\" and \"---\" for export. + +When this option is turned on, these strings will be exported as: + + Org HTML LaTeX + -----+----------+-------- + \\- ­ \\- + -- – -- + --- — --- + ... … \ldots + +This option can also be set with the #+OPTIONS line, +e.g. \"-:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-sub-superscripts t + "Non-nil means interpret \"_\" and \"^\" for export. + +When this option is turned on, you can use TeX-like syntax for +sub- and superscripts. Several characters after \"_\" or \"^\" +will be considered as a single item - so grouping with {} is +normally not needed. For example, the following things will be +parsed as single sub- or superscripts. + + 10^24 or 10^tau several digits will be considered 1 item. + 10^-12 or 10^-tau a leading sign with digits or a word + x^2-y^3 will be read as x^2 - y^3, because items are + terminated by almost any nonword/nondigit char. + x_{i^2} or x^(2-i) braces or parenthesis do grouping. + +Still, ambiguity is possible - so when in doubt use {} to enclose +the sub/superscript. If you set this variable to the symbol +`{}', the braces are *required* in order to trigger +interpretations as sub/superscript. This can be helpful in +documents that need \"_\" frequently in plain text. + +This option can also be set with the #+OPTIONS line, +e.g. \"^:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "Interpret them" t) + (const :tag "Curly brackets only" {}) + (const :tag "Do not interpret them" nil))) + +(defcustom org-export-with-toc t + "Non-nil means create a table of contents in exported files. + +The TOC contains headlines with levels up +to`org-export-headline-levels'. When an integer, include levels +up to N in the toc, this may then be different from +`org-export-headline-levels', but it will not be allowed to be +larger than the number of headline levels. When nil, no table of +contents is made. + +This option can also be set with the #+OPTIONS line, +e.g. \"toc:nil\" or \"toc:3\"." + :group 'org-export-general + :type '(choice + (const :tag "No Table of Contents" nil) + (const :tag "Full Table of Contents" t) + (integer :tag "TOC to level"))) + +(defcustom org-export-with-tables t + "If non-nil, lines starting with \"|\" define a table. +For example: + + | Name | Address | Birthday | + |-------------+----------+-----------| + | Arthur Dent | England | 29.2.2100 | + +This option can also be set with the #+OPTIONS line, e.g. \"|:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-tags t + "If nil, do not export tags, just remove them from headlines. + +If this is the symbol `not-in-toc', tags will be removed from +table of contents entries, but still be shown in the headlines of +the document. + +This option can also be set with the #+OPTIONS line, +e.g. \"tags:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "Off" nil) + (const :tag "Not in TOC" not-in-toc) + (const :tag "On" t))) + +(defcustom org-export-with-tasks t + "Non-nil means include TODO items for export. +This may have the following values: +t include tasks independent of state. +todo include only tasks that are not yet done. +done include only tasks that are already done. +nil remove all tasks before export +list of keywords keep only tasks with these keywords" + :group 'org-export-general + :type '(choice + (const :tag "All tasks" t) + (const :tag "No tasks" nil) + (const :tag "Not-done tasks" todo) + (const :tag "Only done tasks" done) + (repeat :tag "Specific TODO keywords" + (string :tag "Keyword")))) + +(defcustom org-export-time-stamp-file t + "Non-nil means insert a time stamp into the exported file. +The time stamp shows when the file was created. + +This option can also be set with the #+OPTIONS line, +e.g. \"timestamp:nil\"." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-with-timestamps t + "Non nil means allow timestamps in export. + +It can be set to `active', `inactive', t or nil, in order to +export, respectively, only active timestamps, only inactive ones, +all of them or none. + +This option can also be set with the #+OPTIONS line, e.g. +\"<:nil\"." + :group 'org-export-general + :type '(choice + (const :tag "All timestamps" t) + (const :tag "Only active timestamps" active) + (const :tag "Only inactive timestamps" inactive) + (const :tag "No timestamp" nil))) + +(defcustom org-export-with-todo-keywords t + "Non-nil means include TODO keywords in export. +When nil, remove all these keywords from the export." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-allow-BIND 'confirm + "Non-nil means allow #+BIND to define local variable values for export. +This is a potential security risk, which is why the user must +confirm the use of these lines." + :group 'org-export-general + :type '(choice + (const :tag "Never" nil) + (const :tag "Always" t) + (const :tag "Ask a confirmation for each file" confirm))) + +(defcustom org-export-snippet-translation-alist nil + "Alist between export snippets back-ends and exporter back-ends. + +This variable allows to provide shortcuts for export snippets. + +For example, with a value of '\(\(\"h\" . \"e-html\"\)\), the +HTML back-end will recognize the contents of \"@@h:<b>@@\" as +HTML code while every other back-end will ignore it." + :group 'org-export-general + :type '(repeat + (cons + (string :tag "Shortcut") + (string :tag "Back-end")))) + +(defcustom org-export-coding-system nil + "Coding system for the exported file." + :group 'org-export-general + :type 'coding-system) + +(defcustom org-export-copy-to-kill-ring t + "Non-nil means exported stuff will also be pushed onto the kill ring." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-initial-scope 'buffer + "The initial scope when exporting with `org-export-dispatch'. +This variable can be either set to `buffer' or `subtree'." + :group 'org-export-general + :type '(choice + (const :tag "Export current buffer" 'buffer) + (const :tag "Export current subtree" 'subtree))) + +(defcustom org-export-show-temporary-export-buffer t + "Non-nil means show buffer after exporting to temp buffer. +When Org exports to a file, the buffer visiting that file is ever +shown, but remains buried. However, when exporting to +a temporary buffer, that buffer is popped up in a second window. +When this variable is nil, the buffer remains buried also in +these cases." + :group 'org-export-general + :type 'boolean) + +(defcustom org-export-dispatch-use-expert-ui nil + "Non-nil means using a non-intrusive `org-export-dispatch'. +In that case, no help buffer is displayed. Though, an indicator +for current export scope is added to the prompt \(i.e. \"b\" when +output is restricted to body only, \"s\" when it is restricted to +the current subtree and \"v\" when only visible elements are +considered for export\). Also, \[?] allows to switch back to +standard mode." + :group 'org-export-general + :type 'boolean) + + + +;;; Defining New Back-ends + +(defmacro org-export-define-backend (backend translators &rest body) + "Define a new back-end BACKEND. + +TRANSLATORS is an alist between object or element types and +functions handling them. + +These functions should return a string without any trailing +space, or nil. They must accept three arguments: the object or +element itself, its contents or nil when it isn't recursive and +the property list used as a communication channel. + +Contents, when not nil, are stripped from any global indentation +\(although the relative one is preserved). They also always end +with a single newline character. + +If, for a given type, no function is found, that element or +object type will simply be ignored, along with any blank line or +white space at its end. The same will happen if the function +returns the nil value. If that function returns the empty +string, the type will be ignored, but the blank lines or white +spaces will be kept. + +In addition to element and object types, one function can be +associated to the `template' symbol and another one to the +`plain-text' symbol. + +The former returns the final transcoded string, and can be used +to add a preamble and a postamble to document's body. It must +accept two arguments: the transcoded string and the property list +containing export options. + +The latter, when defined, is to be called on every text not +recognized as an element or an object. It must accept two +arguments: the text string and the information channel. It is an +appropriate place to protect special chars relative to the +back-end. + +BODY can start with pre-defined keyword arguments. The following +keywords are understood: + + :export-block + + String, or list of strings, representing block names that + will not be parsed. This is used to specify blocks that will + contain raw code specific to the back-end. These blocks + still have to be handled by the relative `export-block' type + translator. + + :filters-alist + + Alist between filters and function, or list of functions, + specific to the back-end. See `org-export-filters-alist' for + a list of all allowed filters. Filters defined here + shouldn't make a back-end test, as it may prevent back-ends + derived from this one to behave properly. + + :options-alist + + Alist between back-end specific properties introduced in + communication channel and how their value are acquired. See + `org-export-options-alist' for more information about + structure of the values. + +As an example, here is how the `e-ascii' back-end is defined: + +\(org-export-define-backend e-ascii + \((bold . org-e-ascii-bold) + \(center-block . org-e-ascii-center-block) + \(clock . org-e-ascii-clock) + \(code . org-e-ascii-code) + \(drawer . org-e-ascii-drawer) + \(dynamic-block . org-e-ascii-dynamic-block) + \(entity . org-e-ascii-entity) + \(example-block . org-e-ascii-example-block) + \(export-block . org-e-ascii-export-block) + \(export-snippet . org-e-ascii-export-snippet) + \(fixed-width . org-e-ascii-fixed-width) + \(footnote-definition . org-e-ascii-footnote-definition) + \(footnote-reference . org-e-ascii-footnote-reference) + \(headline . org-e-ascii-headline) + \(horizontal-rule . org-e-ascii-horizontal-rule) + \(inline-src-block . org-e-ascii-inline-src-block) + \(inlinetask . org-e-ascii-inlinetask) + \(italic . org-e-ascii-italic) + \(item . org-e-ascii-item) + \(keyword . org-e-ascii-keyword) + \(latex-environment . org-e-ascii-latex-environment) + \(latex-fragment . org-e-ascii-latex-fragment) + \(line-break . org-e-ascii-line-break) + \(link . org-e-ascii-link) + \(macro . org-e-ascii-macro) + \(paragraph . org-e-ascii-paragraph) + \(plain-list . org-e-ascii-plain-list) + \(plain-text . org-e-ascii-plain-text) + \(planning . org-e-ascii-planning) + \(property-drawer . org-e-ascii-property-drawer) + \(quote-block . org-e-ascii-quote-block) + \(quote-section . org-e-ascii-quote-section) + \(radio-target . org-e-ascii-radio-target) + \(section . org-e-ascii-section) + \(special-block . org-e-ascii-special-block) + \(src-block . org-e-ascii-src-block) + \(statistics-cookie . org-e-ascii-statistics-cookie) + \(strike-through . org-e-ascii-strike-through) + \(subscript . org-e-ascii-subscript) + \(superscript . org-e-ascii-superscript) + \(table . org-e-ascii-table) + \(table-cell . org-e-ascii-table-cell) + \(table-row . org-e-ascii-table-row) + \(target . org-e-ascii-target) + \(template . org-e-ascii-template) + \(timestamp . org-e-ascii-timestamp) + \(underline . org-e-ascii-underline) + \(verbatim . org-e-ascii-verbatim) + \(verse-block . org-e-ascii-verse-block)) + :export-block \"ASCII\" + :filters-alist ((:filter-headline . org-e-ascii-filter-headline-blank-lines) + \(:filter-section . org-e-ascii-filter-headline-blank-lines)) + :options-alist ((:ascii-charset nil nil org-e-ascii-charset)))" + (declare (debug (&define name sexp [&rest [keywordp sexp]] defbody)) + (indent 1)) + (let (filters options export-block) + (while (keywordp (car body)) + (case (pop body) + (:export-block (let ((names (pop body))) + (setq export-block + (if (consp names) (mapcar 'upcase names) + (list (upcase names)))))) + (:filters-alist (setq filters (pop body))) + (:options-alist (setq options (pop body))) + (t (pop body)))) + `(progn + ;; Define translators. + (defvar ,(intern (format "org-%s-translate-alist" backend)) ',translators + "Alist between element or object types and translators.") + ;; Define options. + ,(when options + `(defconst ,(intern (format "org-%s-options-alist" backend)) ',options + ,(format "Alist between %s export properties and ways to set them. +See `org-export-options-alist' for more information on the +structure of the values." + backend))) + ;; Define filters. + ,(when filters + `(defconst ,(intern (format "org-%s-filters-alist" backend)) ',filters + "Alist between filters keywords and back-end specific filters. +See `org-export-filters-alist' for more information.")) + ;; Tell parser to not parse EXPORT-BLOCK blocks. + ,(when export-block + `(mapc + (lambda (name) + (add-to-list 'org-element-block-name-alist + `(,name . org-element-export-block-parser))) + ',export-block)) + ;; Splice in the body, if any. + ,@body))) + +(defmacro org-export-define-derived-backend (child parent &rest body) + "Create a new back-end as a variant of an existing one. + +CHILD is the name of the derived back-end. PARENT is the name of +the parent back-end. + +BODY can start with pre-defined keyword arguments. The following +keywords are understood: + + :export-block + + String, or list of strings, representing block names that + will not be parsed. This is used to specify blocks that will + contain raw code specific to the back-end. These blocks + still have to be handled by the relative `export-block' type + translator. + + :filters-alist + + Alist of filters that will overwrite or complete filters + defined in PARENT back-end. See `org-export-filters-alist' + for more a list of allowed filters. + + :options-alist + + Alist of back-end specific properties that will overwrite or + complete those defined in PARENT back-end. Refer to + `org-export-options-alist' for more information about + structure of the values. + + :translate-alist + + Alist of element and object types and transcoders that will + overwrite or complete transcode table from PARENT back-end. + Refer to `org-export-define-backend' for detailed information + about transcoders. + +As an example, here is how one could define \"my-latex\" back-end +as a variant of `e-latex' back-end with a custom template +function: + + \(org-export-define-derived-backend my-latex e-latex + :translate-alist ((template . my-latex-template-fun))) + +The back-end could then be called with, for example: + + \(org-export-to-buffer 'my-latex \"*Test my-latex*\")" + (declare (debug (&define name sexp [&rest [keywordp sexp]] def-body)) + (indent 2)) + (let (filters options translate export-block) + (while (keywordp (car body)) + (case (pop body) + (:export-block (let ((names (pop body))) + (setq export-block + (if (consp names) (mapcar 'upcase names) + (list (upcase names)))))) + (:filters-alist (setq filters (pop body))) + (:options-alist (setq options (pop body))) + (:translate-alist (setq translate (pop body))) + (t (pop body)))) + `(progn + ;; Tell parser to not parse EXPORT-BLOCK blocks. + ,(when export-block + `(mapc + (lambda (name) + (add-to-list 'org-element-block-name-alist + `(,name . org-element-export-block-parser))) + ',export-block)) + ;; Define filters. + ,(let ((parent-filters (intern (format "org-%s-filters-alist" parent)))) + (when (or (boundp parent-filters) filters) + `(defconst ,(intern (format "org-%s-filters-alist" child)) + ',(append filters + (and (boundp parent-filters) + (copy-sequence (symbol-value parent-filters)))) + "Alist between filters keywords and back-end specific filters. +See `org-export-filters-alist' for more information."))) + ;; Define options. + ,(let ((parent-options (intern (format "org-%s-options-alist" parent)))) + (when (or (boundp parent-options) options) + `(defconst ,(intern (format "org-%s-options-alist" child)) + ',(append options + (and (boundp parent-options) + (copy-sequence (symbol-value parent-options)))) + ,(format "Alist between %s export properties and ways to set them. +See `org-export-options-alist' for more information on the +structure of the values." + child)))) + ;; Define translators. + (defvar ,(intern (format "org-%s-translate-alist" child)) + ',(append translate + (copy-sequence + (symbol-value + (intern (format "org-%s-translate-alist" parent))))) + "Alist between element or object types and translators.") + ;; Splice in the body, if any. + ,@body))) + + + +;;; The Communication Channel +;; +;; During export process, every function has access to a number of +;; properties. They are of two types: +;; +;; 1. Environment options are collected once at the very beginning of +;; the process, out of the original buffer and configuration. +;; Collecting them is handled by `org-export-get-environment' +;; function. +;; +;; Most environment options are defined through the +;; `org-export-options-alist' variable. +;; +;; 2. Tree properties are extracted directly from the parsed tree, +;; just before export, by `org-export-collect-tree-properties'. +;; +;; Here is the full list of properties available during transcode +;; process, with their category (option, tree or local) and their +;; value type. +;; +;; + `:author' :: Author's name. +;; - category :: option +;; - type :: string +;; +;; + `:back-end' :: Current back-end used for transcoding. +;; - category :: tree +;; - type :: symbol +;; +;; + `:creator' :: String to write as creation information. +;; - category :: option +;; - type :: string +;; +;; + `:date' :: String to use as date. +;; - category :: option +;; - type :: string +;; +;; + `:description' :: Description text for the current data. +;; - category :: option +;; - type :: string +;; +;; + `:email' :: Author's email. +;; - category :: option +;; - type :: string +;; +;; + `:exclude-tags' :: Tags for exclusion of subtrees from export +;; process. +;; - category :: option +;; - type :: list of strings +;; +;; + `:exported-data' :: Hash table used for memoizing +;; `org-export-data'. +;; - category :: tree +;; - type :: hash table +;; +;; + `:footnote-definition-alist' :: Alist between footnote labels and +;; their definition, as parsed data. Only non-inlined footnotes +;; are represented in this alist. Also, every definition isn't +;; guaranteed to be referenced in the parse tree. The purpose of +;; this property is to preserve definitions from oblivion +;; (i.e. when the parse tree comes from a part of the original +;; buffer), it isn't meant for direct use in a back-end. To +;; retrieve a definition relative to a reference, use +;; `org-export-get-footnote-definition' instead. +;; - category :: option +;; - type :: alist (STRING . LIST) +;; +;; + `:headline-levels' :: Maximum level being exported as an +;; headline. Comparison is done with the relative level of +;; headlines in the parse tree, not necessarily with their +;; actual level. +;; - category :: option +;; - type :: integer +;; +;; + `:headline-offset' :: Difference between relative and real level +;; of headlines in the parse tree. For example, a value of -1 +;; means a level 2 headline should be considered as level +;; 1 (cf. `org-export-get-relative-level'). +;; - category :: tree +;; - type :: integer +;; +;; + `:headline-numbering' :: Alist between headlines and their +;; numbering, as a list of numbers +;; (cf. `org-export-get-headline-number'). +;; - category :: tree +;; - type :: alist (INTEGER . LIST) +;; +;; + `:id-alist' :: Alist between ID strings and destination file's +;; path, relative to current directory. It is used by +;; `org-export-resolve-id-link' to resolve ID links targeting an +;; external file. +;; - category :: option +;; - type :: alist (STRING . STRING) +;; +;; + `:ignore-list' :: List of elements and objects that should be +;; ignored during export. +;; - category :: tree +;; - type :: list of elements and objects +;; +;; + `:input-file' :: Full path to input file, if any. +;; - category :: option +;; - type :: string or nil +;; +;; + `:keywords' :: List of keywords attached to data. +;; - category :: option +;; - type :: string +;; +;; + `:language' :: Default language used for translations. +;; - category :: option +;; - type :: string +;; +;; + `:parse-tree' :: Whole parse tree, available at any time during +;; transcoding. +;; - category :: option +;; - type :: list (as returned by `org-element-parse-buffer') +;; +;; + `:preserve-breaks' :: Non-nil means transcoding should preserve +;; all line breaks. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:section-numbers' :: Non-nil means transcoding should add +;; section numbers to headlines. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:select-tags' :: List of tags enforcing inclusion of sub-trees +;; in transcoding. When such a tag is present, subtrees without +;; it are de facto excluded from the process. See +;; `use-select-tags'. +;; - category :: option +;; - type :: list of strings +;; +;; + `:target-list' :: List of targets encountered in the parse tree. +;; This is used to partly resolve "fuzzy" links +;; (cf. `org-export-resolve-fuzzy-link'). +;; - category :: tree +;; - type :: list of strings +;; +;; + `:time-stamp-file' :: Non-nil means transcoding should insert +;; a time stamp in the output. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:translate-alist' :: Alist between element and object types and +;; transcoding functions relative to the current back-end. +;; Special keys `template' and `plain-text' are also possible. +;; - category :: option +;; - type :: alist (SYMBOL . FUNCTION) +;; +;; + `:with-archived-trees' :: Non-nil when archived subtrees should +;; also be transcoded. If it is set to the `headline' symbol, +;; only the archived headline's name is retained. +;; - category :: option +;; - type :: symbol (nil, t, `headline') +;; +;; + `:with-author' :: Non-nil means author's name should be included +;; in the output. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-clocks' :: Non-nild means clock keywords should be exported. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-creator' :: Non-nild means a creation sentence should be +;; inserted at the end of the transcoded string. If the value +;; is `comment', it should be commented. +;; - category :: option +;; - type :: symbol (`comment', nil, t) +;; +;; + `:with-drawers' :: Non-nil means drawers should be exported. If +;; its value is a list of names, only drawers with such names +;; will be transcoded. +;; - category :: option +;; - type :: symbol (nil, t) or list of strings +;; +;; + `:with-email' :: Non-nil means output should contain author's +;; email. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-emphasize' :: Non-nil means emphasized text should be +;; interpreted. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-fixed-width' :: Non-nil if transcoder should interpret +;; strings starting with a colon as a fixed-with (verbatim) area. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-footnotes' :: Non-nil if transcoder should interpret +;; footnotes. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-plannings' :: Non-nil means transcoding should include +;; planning info. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-priority' :: Non-nil means transcoding should include +;; priority cookies. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-special-strings' :: Non-nil means transcoding should +;; interpret special strings in plain text. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-sub-superscript' :: Non-nil means transcoding should +;; interpret subscript and superscript. With a value of "{}", +;; only interpret those using curly brackets. +;; - category :: option +;; - type :: symbol (nil, {}, t) +;; +;; + `:with-tables' :: Non-nil means transcoding should interpret +;; tables. +;; - category :: option +;; - type :: symbol (nil, t) +;; +;; + `:with-tags' :: Non-nil means transcoding should keep tags in +;; headlines. A `not-in-toc' value will remove them from the +;; table of contents, if any, nonetheless. +;; - category :: option +;; - type :: symbol (nil, t, `not-in-toc') +;; +;; + `:with-tasks' :: Non-nil means transcoding should include +;; headlines with a TODO keyword. A `todo' value will only +;; include headlines with a todo type keyword while a `done' +;; value will do the contrary. If a list of strings is provided, +;; only tasks with keywords belonging to that list will be kept. +;; - category :: option +;; - type :: symbol (t, todo, done, nil) or list of strings +;; +;; + `:with-timestamps' :: Non-nil means transcoding should include +;; time stamps. Special value `active' (resp. `inactive') ask to +;; export only active (resp. inactive) timestamps. Otherwise, +;; completely remove them. +;; - category :: option +;; - type :: symbol: (`active', `inactive', t, nil) +;; +;; + `:with-toc' :: Non-nil means that a table of contents has to be +;; added to the output. An integer value limits its depth. +;; - category :: option +;; - type :: symbol (nil, t or integer) +;; +;; + `:with-todo-keywords' :: Non-nil means transcoding should +;; include TODO keywords. +;; - category :: option +;; - type :: symbol (nil, t) + + +;;;; Environment Options +;; +;; Environment options encompass all parameters defined outside the +;; scope of the parsed data. They come from five sources, in +;; increasing precedence order: +;; +;; - Global variables, +;; - Buffer's attributes, +;; - Options keyword symbols, +;; - Buffer keywords, +;; - Subtree properties. +;; +;; The central internal function with regards to environment options +;; is `org-export-get-environment'. It updates global variables with +;; "#+BIND:" keywords, then retrieve and prioritize properties from +;; the different sources. +;; +;; The internal functions doing the retrieval are: +;; `org-export--get-global-options', +;; `org-export--get-buffer-attributes', +;; `org-export--parse-option-keyword', +;; `org-export--get-subtree-options' and +;; `org-export--get-inbuffer-options' +;; +;; Also, `org-export--confirm-letbind' and `org-export--install-letbind' +;; take care of the part relative to "#+BIND:" keywords. + +(defun org-export-get-environment (&optional backend subtreep ext-plist) + "Collect export options from the current buffer. + +Optional argument BACKEND is a symbol specifying which back-end +specific options to read, if any. + +When optional argument SUBTREEP is non-nil, assume the export is +done against the current sub-tree. + +Third optional argument EXT-PLIST is a property list with +external parameters overriding Org default settings, but still +inferior to file-local settings." + ;; First install #+BIND variables. + (org-export--install-letbind-maybe) + ;; Get and prioritize export options... + (org-combine-plists + ;; ... from global variables... + (org-export--get-global-options backend) + ;; ... from buffer's attributes... + (org-export--get-buffer-attributes) + ;; ... from an external property list... + ext-plist + ;; ... from in-buffer settings... + (org-export--get-inbuffer-options + backend + (and buffer-file-name (org-remove-double-quotes buffer-file-name))) + ;; ... and from subtree, when appropriate. + (and subtreep (org-export--get-subtree-options backend)) + ;; Eventually install back-end symbol and its translation table. + `(:back-end + ,backend + :translate-alist + ,(let ((trans-alist (intern (format "org-%s-translate-alist" backend)))) + (when (boundp trans-alist) (symbol-value trans-alist)))))) + +(defun org-export--parse-option-keyword (options &optional backend) + "Parse an OPTIONS line and return values as a plist. +Optional argument BACKEND is a symbol specifying which back-end +specific items to read, if any." + (let* ((all + (append org-export-options-alist + (and backend + (let ((var (intern + (format "org-%s-options-alist" backend)))) + (and (boundp var) (eval var)))))) + ;; Build an alist between #+OPTION: item and property-name. + (alist (delq nil + (mapcar (lambda (e) + (when (nth 2 e) (cons (regexp-quote (nth 2 e)) + (car e)))) + all))) + plist) + (mapc (lambda (e) + (when (string-match (concat "\\(\\`\\|[ \t]\\)" + (car e) + ":\\(([^)\n]+)\\|[^ \t\n\r;,.]*\\)") + options) + (setq plist (plist-put plist + (cdr e) + (car (read-from-string + (match-string 2 options))))))) + alist) + plist)) + +(defun org-export--get-subtree-options (&optional backend) + "Get export options in subtree at point. +Optional argument BACKEND is a symbol specifying back-end used +for export. Return options as a plist." + ;; For each buffer keyword, create an headline property setting the + ;; same property in communication channel. The name for the property + ;; is the keyword with "EXPORT_" appended to it. + (org-with-wide-buffer + (let (prop plist) + ;; Make sure point is at an heading. + (unless (org-at-heading-p) (org-back-to-heading t)) + ;; Take care of EXPORT_TITLE. If it isn't defined, use headline's + ;; title as its fallback value. + (when (setq prop (progn (looking-at org-todo-line-regexp) + (or (save-match-data + (org-entry-get (point) "EXPORT_TITLE")) + (org-match-string-no-properties 3)))) + (setq plist + (plist-put + plist :title + (org-element-parse-secondary-string + prop (org-element-restriction 'keyword))))) + ;; EXPORT_OPTIONS are parsed in a non-standard way. + (when (setq prop (org-entry-get (point) "EXPORT_OPTIONS")) + (setq plist + (nconc plist (org-export--parse-option-keyword prop backend)))) + ;; Handle other keywords. + (let ((seen '("TITLE"))) + (mapc + (lambda (option) + (let ((property (nth 1 option))) + (when (and property (not (member property seen))) + (let* ((subtree-prop (concat "EXPORT_" property)) + ;; Export properties are not case-sensitive. + (value (let ((case-fold-search t)) + (org-entry-get (point) subtree-prop)))) + (push property seen) + (when value + (setq plist + (plist-put + plist + (car option) + ;; Parse VALUE if required. + (if (member property org-element-parsed-keywords) + (org-element-parse-secondary-string + value (org-element-restriction 'keyword)) + value)))))))) + ;; Also look for both general keywords and back-end specific + ;; options if BACKEND is provided. + (append (and backend + (let ((var (intern + (format "org-%s-options-alist" backend)))) + (and (boundp var) (symbol-value var)))) + org-export-options-alist))) + ;; Return value. + plist))) + +(defun org-export--get-inbuffer-options (&optional backend files) + "Return current buffer export options, as a plist. + +Optional argument BACKEND, when non-nil, is a symbol specifying +which back-end specific options should also be read in the +process. + +Optional argument FILES is a list of setup files names read so +far, used to avoid circular dependencies. + +Assume buffer is in Org mode. Narrowing, if any, is ignored." + (org-with-wide-buffer + (goto-char (point-min)) + (let ((case-fold-search t) plist) + ;; 1. Special keywords, as in `org-export-special-keywords'. + (let ((special-re (org-make-options-regexp org-export-special-keywords))) + (while (re-search-forward special-re nil t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'keyword) + (let* ((key (org-element-property :key element)) + (val (org-element-property :value element)) + (prop + (cond + ((string= key "SETUP_FILE") + (let ((file + (expand-file-name + (org-remove-double-quotes (org-trim val))))) + ;; Avoid circular dependencies. + (unless (member file files) + (with-temp-buffer + (insert (org-file-contents file 'noerror)) + (org-mode) + (org-export--get-inbuffer-options + backend (cons file files)))))) + ((string= key "OPTIONS") + (org-export--parse-option-keyword val backend)) + ((string= key "MACRO") + (when (string-match + "^\\([-a-zA-Z0-9_]+\\)\\(?:[ \t]+\\(.*?\\)[ \t]*$\\)?" + val) + (let ((key + (intern + (concat ":macro-" + (downcase (match-string 1 val))))) + (value (org-match-string-no-properties 2 val))) + (cond + ((not value) nil) + ;; Value will be evaled: do not parse it. + ((string-match "\\`(eval\\>" value) + (list key (list value))) + ;; Value has to be parsed for nested + ;; macros. + (t + (list + key + (let ((restr (org-element-restriction 'macro))) + (org-element-parse-secondary-string + ;; If user explicitly asks for + ;; a newline, be sure to preserve it + ;; from further filling with + ;; `hard-newline'. Also replace + ;; "\\n" with "\n", "\\\n" with "\\n" + ;; and so on... + (replace-regexp-in-string + "\\(\\\\\\\\\\)n" "\\\\" + (replace-regexp-in-string + "\\(?:^\\|[^\\\\]\\)\\(\\\\n\\)" + hard-newline value nil nil 1) + nil nil 1) + restr))))))))))) + (setq plist (org-combine-plists plist prop))))))) + ;; 2. Standard options, as in `org-export-options-alist'. + (let* ((all (append org-export-options-alist + ;; Also look for back-end specific options + ;; if BACKEND is defined. + (and backend + (let ((var + (intern + (format "org-%s-options-alist" backend)))) + (and (boundp var) (eval var)))))) + ;; Build alist between keyword name and property name. + (alist + (delq nil (mapcar + (lambda (e) (when (nth 1 e) (cons (nth 1 e) (car e)))) + all))) + ;; Build regexp matching all keywords associated to export + ;; options. Note: the search is case insensitive. + (opt-re (org-make-options-regexp + (delq nil (mapcar (lambda (e) (nth 1 e)) all))))) + (goto-char (point-min)) + (while (re-search-forward opt-re nil t) + (let ((element (org-element-at-point))) + (when (eq (org-element-type element) 'keyword) + (let* ((key (org-element-property :key element)) + (val (org-element-property :value element)) + (prop (cdr (assoc key alist))) + (behaviour (nth 4 (assq prop all)))) + (setq plist + (plist-put + plist prop + ;; Handle value depending on specified BEHAVIOUR. + (case behaviour + (space + (if (not (plist-get plist prop)) (org-trim val) + (concat (plist-get plist prop) " " (org-trim val)))) + (newline + (org-trim + (concat (plist-get plist prop) "\n" (org-trim val)))) + (split + `(,@(plist-get plist prop) ,@(org-split-string val))) + ('t val) + (otherwise (if (not (plist-member plist prop)) val + (plist-get plist prop)))))))))) + ;; Parse keywords specified in `org-element-parsed-keywords'. + (mapc + (lambda (key) + (let* ((prop (cdr (assoc key alist))) + (value (and prop (plist-get plist prop)))) + (when (stringp value) + (setq plist + (plist-put + plist prop + (org-element-parse-secondary-string + value (org-element-restriction 'keyword))))))) + org-element-parsed-keywords)) + ;; 3. Return final value. + plist))) + +(defun org-export--get-buffer-attributes () + "Return properties related to buffer attributes, as a plist." + (let ((visited-file (buffer-file-name (buffer-base-buffer)))) + (list + ;; Store full path of input file name, or nil. For internal use. + :input-file visited-file + :title (or (and visited-file + (file-name-sans-extension + (file-name-nondirectory visited-file))) + (buffer-name (buffer-base-buffer))) + :footnote-definition-alist + ;; Footnotes definitions must be collected in the original + ;; buffer, as there's no insurance that they will still be in the + ;; parse tree, due to possible narrowing. + (let (alist) + (org-with-wide-buffer + (goto-char (point-min)) + (while (re-search-forward org-footnote-definition-re nil t) + (let ((def (org-footnote-at-definition-p))) + (when def + (org-skip-whitespace) + (push (cons (car def) + (save-restriction + (narrow-to-region (point) (nth 2 def)) + ;; Like `org-element-parse-buffer', but + ;; makes sure the definition doesn't start + ;; with a section element. + (org-element--parse-elements + (point-min) (point-max) nil nil nil nil + (list 'org-data nil)))) + alist)))) + alist)) + :id-alist + ;; Collect id references. + (let (alist) + (org-with-wide-buffer + (goto-char (point-min)) + (while (re-search-forward + "\\[\\[id:\\(\\S-+?\\)\\]\\(?:\\[.*?\\]\\)?\\]" nil t) + (let* ((id (org-match-string-no-properties 1)) + (file (org-id-find-id-file id))) + (when file (push (cons id (file-relative-name file)) alist))))) + alist) + :macro-modification-time + (and visited-file + (file-exists-p visited-file) + (concat "(eval (format-time-string \"$1\" '" + (prin1-to-string (nth 5 (file-attributes visited-file))) + "))")) + ;; Store input file name as a macro. + :macro-input-file (and visited-file (file-name-nondirectory visited-file)) + ;; `:macro-date', `:macro-time' and `:macro-property' could as + ;; well be initialized as tree properties, since they don't + ;; depend on buffer properties. Though, it may be more logical + ;; to keep them close to other ":macro-" properties. + :macro-date "(eval (format-time-string \"$1\"))" + :macro-time "(eval (format-time-string \"$1\"))" + :macro-property "(eval (org-entry-get nil \"$1\" 'selective))"))) + +(defun org-export--get-global-options (&optional backend) + "Return global export options as a plist. + +Optional argument BACKEND, if non-nil, is a symbol specifying +which back-end specific export options should also be read in the +process." + (let ((all (append org-export-options-alist + (and backend + (let ((var (intern + (format "org-%s-options-alist" backend)))) + (and (boundp var) (symbol-value var)))))) + ;; Output value. + plist) + (mapc + (lambda (cell) + (setq plist + (plist-put + plist + (car cell) + ;; Eval default value provided. If keyword is a member + ;; of `org-element-parsed-keywords', parse it as + ;; a secondary string before storing it. + (let ((value (eval (nth 3 cell)))) + (if (not (stringp value)) value + (let ((keyword (nth 1 cell))) + (if (not (member keyword org-element-parsed-keywords)) value + (org-element-parse-secondary-string + value (org-element-restriction 'keyword))))))))) + all) + ;; Return value. + plist)) + +(defvar org-export--allow-BIND-local nil) +(defun org-export--confirm-letbind () + "Can we use #+BIND values during export? +By default this will ask for confirmation by the user, to divert +possible security risks." + (cond + ((not org-export-allow-BIND) nil) + ((eq org-export-allow-BIND t) t) + ((local-variable-p 'org-export--allow-BIND-local) + org-export--allow-BIND-local) + (t (org-set-local 'org-export--allow-BIND-local + (yes-or-no-p "Allow BIND values in this buffer? "))))) + +(defun org-export--install-letbind-maybe () + "Install the values from #+BIND lines as local variables. +Variables must be installed before in-buffer options are +retrieved." + (let (letbind pair) + (org-with-wide-buffer + (goto-char (point-min)) + (while (re-search-forward (org-make-options-regexp '("BIND")) nil t) + (when (org-export-confirm-letbind) + (push (read (concat "(" (org-match-string-no-properties 2) ")")) + letbind)))) + (while (setq pair (pop letbind)) + (org-set-local (car pair) (nth 1 pair))))) + + +;;;; Tree Properties +;; +;; Tree properties are infromation extracted from parse tree. They +;; are initialized at the beginning of the transcoding process by +;; `org-export-collect-tree-properties'. +;; +;; Dedicated functions focus on computing the value of specific tree +;; properties during initialization. Thus, +;; `org-export--populate-ignore-list' lists elements and objects that +;; should be skipped during export, `org-export--get-min-level' gets +;; the minimal exportable level, used as a basis to compute relative +;; level for headlines. Eventually +;; `org-export--collect-headline-numbering' builds an alist between +;; headlines and their numbering. + +(defun org-export-collect-tree-properties (data info) + "Extract tree properties from parse tree. + +DATA is the parse tree from which information is retrieved. INFO +is a list holding export options. + +Following tree properties are set or updated: + +`:exported-data' Hash table used to memoize results from + `org-export-data'. + +`:footnote-definition-alist' List of footnotes definitions in + original buffer and current parse tree. + +`:headline-offset' Offset between true level of headlines and + local level. An offset of -1 means an headline + of level 2 should be considered as a level + 1 headline in the context. + +`:headline-numbering' Alist of all headlines as key an the + associated numbering as value. + +`:ignore-list' List of elements that should be ignored during + export. + +`:target-list' List of all targets in the parse tree. + +Return updated plist." + ;; Install the parse tree in the communication channel, in order to + ;; use `org-export-get-genealogy' and al. + (setq info (plist-put info :parse-tree data)) + ;; Get the list of elements and objects to ignore, and put it into + ;; `:ignore-list'. Do not overwrite any user ignore that might have + ;; been done during parse tree filtering. + (setq info + (plist-put info + :ignore-list + (append (org-export--populate-ignore-list data info) + (plist-get info :ignore-list)))) + ;; Compute `:headline-offset' in order to be able to use + ;; `org-export-get-relative-level'. + (setq info + (plist-put info + :headline-offset + (- 1 (org-export--get-min-level data info)))) + ;; Update footnotes definitions list with definitions in parse tree. + ;; This is required since buffer expansion might have modified + ;; boundaries of footnote definitions contained in the parse tree. + ;; This way, definitions in `footnote-definition-alist' are bound to + ;; match those in the parse tree. + (let ((defs (plist-get info :footnote-definition-alist))) + (org-element-map + data 'footnote-definition + (lambda (fn) + (push (cons (org-element-property :label fn) + `(org-data nil ,@(org-element-contents fn))) + defs))) + (setq info (plist-put info :footnote-definition-alist defs))) + ;; Properties order doesn't matter: get the rest of the tree + ;; properties. + (nconc + `(:target-list + ,(org-element-map + data '(keyword target) + (lambda (blob) + (when (or (eq (org-element-type blob) 'target) + (string= (org-element-property :key blob) "TARGET")) + blob)) info) + :headline-numbering ,(org-export--collect-headline-numbering data info) + :exported-data ,(make-hash-table :test 'eq :size 4001)) + info)) + +(defun org-export--get-min-level (data options) + "Return minimum exportable headline's level in DATA. +DATA is parsed tree as returned by `org-element-parse-buffer'. +OPTIONS is a plist holding export options." + (catch 'exit + (let ((min-level 10000)) + (mapc + (lambda (blob) + (when (and (eq (org-element-type blob) 'headline) + (not (memq blob (plist-get options :ignore-list)))) + (setq min-level + (min (org-element-property :level blob) min-level))) + (when (= min-level 1) (throw 'exit 1))) + (org-element-contents data)) + ;; If no headline was found, for the sake of consistency, set + ;; minimum level to 1 nonetheless. + (if (= min-level 10000) 1 min-level)))) + +(defun org-export--collect-headline-numbering (data options) + "Return numbering of all exportable headlines in a parse tree. + +DATA is the parse tree. OPTIONS is the plist holding export +options. + +Return an alist whose key is an headline and value is its +associated numbering \(in the shape of a list of numbers\)." + (let ((numbering (make-vector org-export-max-depth 0))) + (org-element-map + data + 'headline + (lambda (headline) + (let ((relative-level + (1- (org-export-get-relative-level headline options)))) + (cons + headline + (loop for n across numbering + for idx from 0 to org-export-max-depth + when (< idx relative-level) collect n + when (= idx relative-level) collect (aset numbering idx (1+ n)) + when (> idx relative-level) do (aset numbering idx 0))))) + options))) + +(defun org-export--populate-ignore-list (data options) + "Return list of elements and objects to ignore during export. +DATA is the parse tree to traverse. OPTIONS is the plist holding +export options." + (let* (ignore + walk-data ; for byte-compiler. + (walk-data + (function + (lambda (data options selected) + ;; Collect ignored elements or objects into IGNORE-LIST. + (mapc + (lambda (el) + (if (org-export--skip-p el options selected) (push el ignore) + (let ((type (org-element-type el))) + (if (and (eq (plist-get options :with-archived-trees) + 'headline) + (eq (org-element-type el) 'headline) + (org-element-property :archivedp el)) + ;; If headline is archived but tree below has + ;; to be skipped, add it to ignore list. + (mapc (lambda (e) (push e ignore)) + (org-element-contents el)) + ;; Move into recursive objects/elements. + (when (org-element-contents el) + (funcall walk-data el options selected)))))) + (org-element-contents data)))))) + ;; Main call. First find trees containing a select tag, if any. + (funcall walk-data data options (org-export--selected-trees data options)) + ;; Return value. + ignore)) + +(defun org-export--selected-trees (data info) + "Return list of headlines containing a select tag in their tree. +DATA is parsed data as returned by `org-element-parse-buffer'. +INFO is a plist holding export options." + (let* (selected-trees + walk-data ; for byte-compiler. + (walk-data + (function + (lambda (data genealogy) + (case (org-element-type data) + (org-data (mapc (lambda (el) (funcall walk-data el genealogy)) + (org-element-contents data))) + (headline + (let ((tags (org-element-property :tags data))) + (if (loop for tag in (plist-get info :select-tags) + thereis (member tag tags)) + ;; When a select tag is found, mark full + ;; genealogy and every headline within the tree + ;; as acceptable. + (setq selected-trees + (append + genealogy + (org-element-map data 'headline 'identity) + selected-trees)) + ;; Else, continue searching in tree, recursively. + (mapc + (lambda (el) (funcall walk-data el (cons data genealogy))) + (org-element-contents data)))))))))) + (funcall walk-data data nil) selected-trees)) + +(defun org-export--skip-p (blob options selected) + "Non-nil when element or object BLOB should be skipped during export. +OPTIONS is the plist holding export options. SELECTED, when +non-nil, is a list of headlines belonging to a tree with a select +tag." + (case (org-element-type blob) + ;; Check headline. + (headline + (let ((with-tasks (plist-get options :with-tasks)) + (todo (org-element-property :todo-keyword blob)) + (todo-type (org-element-property :todo-type blob)) + (archived (plist-get options :with-archived-trees)) + (tags (org-element-property :tags blob))) + (or + ;; Ignore subtrees with an exclude tag. + (loop for k in (plist-get options :exclude-tags) + thereis (member k tags)) + ;; When a select tag is present in the buffer, ignore any tree + ;; without it. + (and selected (not (memq blob selected))) + ;; Ignore commented sub-trees. + (org-element-property :commentedp blob) + ;; Ignore archived subtrees if `:with-archived-trees' is nil. + (and (not archived) (org-element-property :archivedp blob)) + ;; Ignore tasks, if specified by `:with-tasks' property. + (and todo + (or (not with-tasks) + (and (memq with-tasks '(todo done)) + (not (eq todo-type with-tasks))) + (and (consp with-tasks) (not (member todo with-tasks)))))))) + ;; Check inlinetask. + (inlinetask (not (plist-get options :with-inlinetasks))) + ;; Check timestamp. + (timestamp + (case (plist-get options :with-timestamps) + ;; No timestamp allowed. + ('nil t) + ;; Only active timestamps allowed and the current one isn't + ;; active. + (active + (not (memq (org-element-property :type blob) + '(active active-range)))) + ;; Only inactive timestamps allowed and the current one isn't + ;; inactive. + (inactive + (not (memq (org-element-property :type blob) + '(inactive inactive-range)))))) + ;; Check drawer. + (drawer + (or (not (plist-get options :with-drawers)) + (and (consp (plist-get options :with-drawers)) + (not (member (org-element-property :drawer-name blob) + (plist-get options :with-drawers)))))) + ;; Check table-row. + (table-row (org-export-table-row-is-special-p blob options)) + ;; Check table-cell. + (table-cell + (and (org-export-table-has-special-column-p + (org-export-get-parent-table blob)) + (not (org-export-get-previous-element blob options)))) + ;; Check clock. + (clock (not (plist-get options :with-clocks))) + ;; Check planning. + (planning (not (plist-get options :with-plannings))))) + + + +;;; The Transcoder +;; +;; `org-export-data' reads a parse tree (obtained with, i.e. +;; `org-element-parse-buffer') and transcodes it into a specified +;; back-end output. It takes care of filtering out elements or +;; objects according to export options and organizing the output blank +;; lines and white space are preserved. The function memoizes its +;; results, so it is cheap to call it within translators. +;; +;; Internally, three functions handle the filtering of objects and +;; elements during the export. In particular, +;; `org-export-ignore-element' marks an element or object so future +;; parse tree traversals skip it, `org-export--interpret-p' tells which +;; elements or objects should be seen as real Org syntax and +;; `org-export-expand' transforms the others back into their original +;; shape +;; +;; `org-export-transcoder' is an accessor returning appropriate +;; translator function for a given element or object. + +(defun org-export-transcoder (blob info) + "Return appropriate transcoder for BLOB. +INFO is a plist containing export directives." + (let ((type (org-element-type blob))) + ;; Return contents only for complete parse trees. + (if (eq type 'org-data) (lambda (blob contents info) contents) + (let ((transcoder (cdr (assq type (plist-get info :translate-alist))))) + (and (functionp transcoder) transcoder))))) + +(defun org-export-data (data info) + "Convert DATA into current back-end format. + +DATA is a parse tree, an element or an object or a secondary +string. INFO is a plist holding export options. + +Return transcoded string." + (let ((memo (gethash data (plist-get info :exported-data) 'no-memo))) + (if (not (eq memo 'no-memo)) memo + (let* ((type (org-element-type data)) + (results + (cond + ;; Ignored element/object. + ((memq data (plist-get info :ignore-list)) nil) + ;; Plain text. + ((eq type 'plain-text) + (org-export-filter-apply-functions + (plist-get info :filter-plain-text) + (let ((transcoder (org-export-transcoder data info))) + (if transcoder (funcall transcoder data info) data)) + info)) + ;; Uninterpreted element/object: change it back to Org + ;; syntax and export again resulting raw string. + ((not (org-export--interpret-p data info)) + (org-export-data + (org-export-expand + data + (mapconcat (lambda (blob) (org-export-data blob info)) + (org-element-contents data) + "")) + info)) + ;; Secondary string. + ((not type) + (mapconcat (lambda (obj) (org-export-data obj info)) data "")) + ;; Element/Object without contents or, as a special case, + ;; headline with archive tag and archived trees restricted + ;; to title only. + ((or (not (org-element-contents data)) + (and (eq type 'headline) + (eq (plist-get info :with-archived-trees) 'headline) + (org-element-property :archivedp data))) + (let ((transcoder (org-export-transcoder data info))) + (and (functionp transcoder) + (funcall transcoder data nil info)))) + ;; Element/Object with contents. + (t + (let ((transcoder (org-export-transcoder data info))) + (when transcoder + (let* ((greaterp (memq type org-element-greater-elements)) + (objectp + (and (not greaterp) + (memq type org-element-recursive-objects))) + (contents + (mapconcat + (lambda (element) (org-export-data element info)) + (org-element-contents + (if (or greaterp objectp) data + ;; Elements directly containing objects + ;; must have their indentation normalized + ;; first. + (org-element-normalize-contents + data + ;; When normalizing contents of the first + ;; paragraph in an item or a footnote + ;; definition, ignore first line's + ;; indentation: there is none and it + ;; might be misleading. + (when (eq type 'paragraph) + (let ((parent (org-export-get-parent data))) + (and + (eq (car (org-element-contents parent)) + data) + (memq (org-element-type parent) + '(footnote-definition item)))))))) + ""))) + (funcall transcoder data + (if (not greaterp) contents + (org-element-normalize-string contents)) + info)))))))) + ;; Final result will be memoized before being returned. + (puthash + data + (cond + ((not results) nil) + ((memq type '(org-data plain-text nil)) results) + ;; Append the same white space between elements or objects as in + ;; the original buffer, and call appropriate filters. + (t + (let ((results + (org-export-filter-apply-functions + (plist-get info (intern (format ":filter-%s" type))) + (let ((post-blank (or (org-element-property :post-blank data) + 0))) + (if (memq type org-element-all-elements) + (concat (org-element-normalize-string results) + (make-string post-blank ?\n)) + (concat results (make-string post-blank ? )))) + info))) + results))) + (plist-get info :exported-data)))))) + +(defun org-export--interpret-p (blob info) + "Non-nil if element or object BLOB should be interpreted as Org syntax. +Check is done according to export options INFO, stored as +a plist." + (case (org-element-type blob) + ;; ... entities... + (entity (plist-get info :with-entities)) + ;; ... emphasis... + (emphasis (plist-get info :with-emphasize)) + ;; ... fixed-width areas. + (fixed-width (plist-get info :with-fixed-width)) + ;; ... footnotes... + ((footnote-definition footnote-reference) + (plist-get info :with-footnotes)) + ;; ... sub/superscripts... + ((subscript superscript) + (let ((sub/super-p (plist-get info :with-sub-superscript))) + (if (eq sub/super-p '{}) + (org-element-property :use-brackets-p blob) + sub/super-p))) + ;; ... tables... + (table (plist-get info :with-tables)) + (otherwise t))) + +(defun org-export-expand (blob contents) + "Expand a parsed element or object to its original state. +BLOB is either an element or an object. CONTENTS is its +contents, as a string or nil." + (funcall + (intern (format "org-element-%s-interpreter" (org-element-type blob))) + blob contents)) + +(defun org-export-ignore-element (element info) + "Add ELEMENT to `:ignore-list' in INFO. + +Any element in `:ignore-list' will be skipped when using +`org-element-map'. INFO is modified by side effects." + (plist-put info :ignore-list (cons element (plist-get info :ignore-list)))) + + + +;;; The Filter System +;; +;; Filters allow end-users to tweak easily the transcoded output. +;; They are the functional counterpart of hooks, as every filter in +;; a set is applied to the return value of the previous one. +;; +;; Every set is back-end agnostic. Although, a filter is always +;; called, in addition to the string it applies to, with the back-end +;; used as argument, so it's easy for the end-user to add back-end +;; specific filters in the set. The communication channel, as +;; a plist, is required as the third argument. +;; +;; From the developer side, filters sets can be installed in the +;; process with the help of `org-export-define-backend', which +;; internally sets `org-BACKEND-filters-alist' variable. Each +;; association has a key among the following symbols and a function or +;; a list of functions as value. +;; +;; - `:filter-parse-tree' applies directly on the complete parsed +;; tree. It's the only filters set that doesn't apply to a string. +;; Users can set it through `org-export-filter-parse-tree-functions' +;; variable. +;; +;; - `:filter-final-output' applies to the final transcoded string. +;; Users can set it with `org-export-filter-final-output-functions' +;; variable +;; +;; - `:filter-plain-text' applies to any string not recognized as Org +;; syntax. `org-export-filter-plain-text-functions' allows users to +;; configure it. +;; +;; - `:filter-TYPE' applies on the string returned after an element or +;; object of type TYPE has been transcoded. An user can modify +;; `org-export-filter-TYPE-functions' +;; +;; All filters sets are applied with +;; `org-export-filter-apply-functions' function. Filters in a set are +;; applied in a LIFO fashion. It allows developers to be sure that +;; their filters will be applied first. +;; +;; Filters properties are installed in communication channel with +;; `org-export-install-filters' function. +;; +;; Eventually, a hook (`org-export-before-parsing-hook') is run just +;; before parsing to allow for heavy structure modifications. + + +;;;; Before Parsing Hook + +(defvar org-export-before-parsing-hook nil + "Hook run before parsing an export buffer. + +This is run after include keywords have been expanded and Babel +code executed, on a copy of original buffer's area being +exported. Visibility is the same as in the original one. Point +is left at the beginning of the new one. + +Every function in this hook will be called with one argument: the +back-end currently used, as a symbol.") + + +;;;; Special Filters + +(defvar org-export-filter-parse-tree-functions nil + "List of functions applied to the parsed tree. +Each filter is called with three arguments: the parse tree, as +returned by `org-element-parse-buffer', the back-end, as +a symbol, and the communication channel, as a plist. It must +return the modified parse tree to transcode.") + +(defvar org-export-filter-final-output-functions nil + "List of functions applied to the transcoded string. +Each filter is called with three arguments: the full transcoded +string, the back-end, as a symbol, and the communication channel, +as a plist. It must return a string that will be used as the +final export output.") + +(defvar org-export-filter-plain-text-functions nil + "List of functions applied to plain text. +Each filter is called with three arguments: a string which +contains no Org syntax, the back-end, as a symbol, and the +communication channel, as a plist. It must return a string or +nil.") + + +;;;; Elements Filters + +(defvar org-export-filter-center-block-functions nil + "List of functions applied to a transcoded center block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-clock-functions nil + "List of functions applied to a transcoded clock. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-drawer-functions nil + "List of functions applied to a transcoded drawer. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-dynamic-block-functions nil + "List of functions applied to a transcoded dynamic-block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-headline-functions nil + "List of functions applied to a transcoded headline. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-inlinetask-functions nil + "List of functions applied to a transcoded inlinetask. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-plain-list-functions nil + "List of functions applied to a transcoded plain-list. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-item-functions nil + "List of functions applied to a transcoded item. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-comment-functions nil + "List of functions applied to a transcoded comment. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-comment-block-functions nil + "List of functions applied to a transcoded comment-comment. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-example-block-functions nil + "List of functions applied to a transcoded example-block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-export-block-functions nil + "List of functions applied to a transcoded export-block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-fixed-width-functions nil + "List of functions applied to a transcoded fixed-width. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-footnote-definition-functions nil + "List of functions applied to a transcoded footnote-definition. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-horizontal-rule-functions nil + "List of functions applied to a transcoded horizontal-rule. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-keyword-functions nil + "List of functions applied to a transcoded keyword. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-latex-environment-functions nil + "List of functions applied to a transcoded latex-environment. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-babel-call-functions nil + "List of functions applied to a transcoded babel-call. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-paragraph-functions nil + "List of functions applied to a transcoded paragraph. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-planning-functions nil + "List of functions applied to a transcoded planning. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-property-drawer-functions nil + "List of functions applied to a transcoded property-drawer. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-quote-block-functions nil + "List of functions applied to a transcoded quote block. +Each filter is called with three arguments: the transcoded quote +data, as a string, the back-end, as a symbol, and the +communication channel, as a plist. It must return a string or +nil.") + +(defvar org-export-filter-quote-section-functions nil + "List of functions applied to a transcoded quote-section. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-section-functions nil + "List of functions applied to a transcoded section. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-special-block-functions nil + "List of functions applied to a transcoded special block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-src-block-functions nil + "List of functions applied to a transcoded src-block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-table-functions nil + "List of functions applied to a transcoded table. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-table-cell-functions nil + "List of functions applied to a transcoded table-cell. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-table-row-functions nil + "List of functions applied to a transcoded table-row. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-verse-block-functions nil + "List of functions applied to a transcoded verse block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + + +;;;; Objects Filters + +(defvar org-export-filter-bold-functions nil + "List of functions applied to transcoded bold text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-code-functions nil + "List of functions applied to transcoded code text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-entity-functions nil + "List of functions applied to a transcoded entity. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-export-snippet-functions nil + "List of functions applied to a transcoded export-snippet. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-footnote-reference-functions nil + "List of functions applied to a transcoded footnote-reference. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-inline-babel-call-functions nil + "List of functions applied to a transcoded inline-babel-call. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-inline-src-block-functions nil + "List of functions applied to a transcoded inline-src-block. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-italic-functions nil + "List of functions applied to transcoded italic text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-latex-fragment-functions nil + "List of functions applied to a transcoded latex-fragment. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-line-break-functions nil + "List of functions applied to a transcoded line-break. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-link-functions nil + "List of functions applied to a transcoded link. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-macro-functions nil + "List of functions applied to a transcoded macro. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-radio-target-functions nil + "List of functions applied to a transcoded radio-target. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-statistics-cookie-functions nil + "List of functions applied to a transcoded statistics-cookie. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-strike-through-functions nil + "List of functions applied to transcoded strike-through text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-subscript-functions nil + "List of functions applied to a transcoded subscript. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-superscript-functions nil + "List of functions applied to a transcoded superscript. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-target-functions nil + "List of functions applied to a transcoded target. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-timestamp-functions nil + "List of functions applied to a transcoded timestamp. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-underline-functions nil + "List of functions applied to transcoded underline text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + +(defvar org-export-filter-verbatim-functions nil + "List of functions applied to transcoded verbatim text. +Each filter is called with three arguments: the transcoded data, +as a string, the back-end, as a symbol, and the communication +channel, as a plist. It must return a string or nil.") + + +;;;; Filters Tools +;; +;; Internal function `org-export-install-filters' installs filters +;; hard-coded in back-ends (developer filters) and filters from global +;; variables (user filters) in the communication channel. +;; +;; Internal function `org-export-filter-apply-functions' takes care +;; about applying each filter in order to a given data. It ignores +;; filters returning a nil value but stops whenever a filter returns +;; an empty string. + +(defun org-export-filter-apply-functions (filters value info) + "Call every function in FILTERS. + +Functions are called with arguments VALUE, current export +back-end and INFO. A function returning a nil value will be +skipped. If it returns the empty string, the process ends and +VALUE is ignored. + +Call is done in a LIFO fashion, to be sure that developer +specified filters, if any, are called first." + (catch 'exit + (dolist (filter filters value) + (let ((result (funcall filter value (plist-get info :back-end) info))) + (cond ((not value)) + ((equal value "") (throw 'exit nil)) + (t (setq value result))))))) + +(defun org-export-install-filters (info) + "Install filters properties in communication channel. + +INFO is a plist containing the current communication channel. + +Return the updated communication channel." + (let (plist) + ;; Install user defined filters with `org-export-filters-alist'. + (mapc (lambda (p) + (setq plist (plist-put plist (car p) (eval (cdr p))))) + org-export-filters-alist) + ;; Prepend back-end specific filters to that list. + (let ((back-end-filters (intern (format "org-%s-filters-alist" + (plist-get info :back-end))))) + (when (boundp back-end-filters) + (mapc (lambda (p) + ;; Single values get consed, lists are prepended. + (let ((key (car p)) (value (cdr p))) + (when value + (setq plist + (plist-put + plist key + (if (atom value) (cons value (plist-get plist key)) + (append value (plist-get plist key)))))))) + (eval back-end-filters)))) + ;; Return new communication channel. + (org-combine-plists info plist))) + + + +;;; Core functions +;; +;; This is the room for the main function, `org-export-as', along with +;; its derivatives, `org-export-to-buffer' and `org-export-to-file'. +;; They differ only by the way they output the resulting code. +;; +;; `org-export-output-file-name' is an auxiliary function meant to be +;; used with `org-export-to-file'. With a given extension, it tries +;; to provide a canonical file name to write export output to. +;; +;; Note that `org-export-as' doesn't really parse the current buffer, +;; but a copy of it (with the same buffer-local variables and +;; visibility), where include keywords are expanded and Babel blocks +;; are executed, if appropriate. +;; `org-export-with-current-buffer-copy' macro prepares that copy. +;; +;; File inclusion is taken care of by +;; `org-export-expand-include-keyword' and +;; `org-export--prepare-file-contents'. Structure wise, including +;; a whole Org file in a buffer often makes little sense. For +;; example, if the file contains an headline and the include keyword +;; was within an item, the item should contain the headline. That's +;; why file inclusion should be done before any structure can be +;; associated to the file, that is before parsing. + +(defun org-export-as + (backend &optional subtreep visible-only body-only ext-plist noexpand) + "Transcode current Org buffer into BACKEND code. + +If narrowing is active in the current buffer, only transcode its +narrowed part. + +If a region is active, transcode that region. + +When optional argument SUBTREEP is non-nil, transcode the +sub-tree at point, extracting information from the headline +properties first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument BODY-ONLY is non-nil, only return body +code, without preamble nor postamble. + +Optional argument EXT-PLIST, when provided, is a property list +with external parameters overriding Org default settings, but +still inferior to file-local settings. + +Optional argument NOEXPAND, when non-nil, prevents included files +to be expanded and Babel code to be executed. + +Return code as a string." + (save-excursion + (save-restriction + ;; Narrow buffer to an appropriate region or subtree for + ;; parsing. If parsing subtree, be sure to remove main headline + ;; too. + (cond ((org-region-active-p) + (narrow-to-region (region-beginning) (region-end))) + (subtreep + (org-narrow-to-subtree) + (goto-char (point-min)) + (forward-line) + (narrow-to-region (point) (point-max)))) + ;; 1. Get export environment from original buffer. Also install + ;; user's and developer's filters. + (let ((info (org-export-install-filters + (org-export-get-environment backend subtreep ext-plist))) + ;; 2. Get parse tree. Buffer isn't parsed directly. + ;; Instead, a temporary copy is created, where include + ;; keywords are expanded and code blocks are evaluated. + (tree (let ((buf (or (buffer-file-name (buffer-base-buffer)) + (current-buffer)))) + (org-export-with-current-buffer-copy + (unless noexpand + (org-export-expand-include-keyword) + ;; TODO: Setting `org-current-export-file' is + ;; required by Org Babel to properly resolve + ;; noweb references. Once "org-exp.el" is + ;; removed, modify + ;; `org-export-blocks-preprocess' so it accepts + ;; the value as an argument instead. + (let ((org-current-export-file buf)) + (org-export-blocks-preprocess))) + (goto-char (point-min)) + ;; Run hook + ;; `org-export-before-parsing-hook'. with current + ;; back-end as argument. + (run-hook-with-args + 'org-export-before-parsing-hook backend) + ;; Eventually parse buffer. + (org-element-parse-buffer nil visible-only))))) + ;; 3. Call parse-tree filters to get the final tree. + (setq tree + (org-export-filter-apply-functions + (plist-get info :filter-parse-tree) tree info)) + ;; 4. Now tree is complete, compute its properties and add + ;; them to communication channel. + (setq info + (org-combine-plists + info (org-export-collect-tree-properties tree info))) + ;; 5. Eventually transcode TREE. Wrap the resulting string + ;; into a template, if required. Eventually call + ;; final-output filter. + (let* ((body (org-element-normalize-string (org-export-data tree info))) + (template (cdr (assq 'template + (plist-get info :translate-alist)))) + (output (org-export-filter-apply-functions + (plist-get info :filter-final-output) + (if (or (not (functionp template)) body-only) body + (funcall template body info)) + info))) + ;; Maybe add final OUTPUT to kill ring, then return it. + (when org-export-copy-to-kill-ring (org-kill-new output)) + output))))) + +(defun org-export-to-buffer + (backend buffer &optional subtreep visible-only body-only ext-plist noexpand) + "Call `org-export-as' with output to a specified buffer. + +BACKEND is the back-end used for transcoding, as a symbol. + +BUFFER is the output buffer. If it already exists, it will be +erased first, otherwise, it will be created. + +Optional arguments SUBTREEP, VISIBLE-ONLY, BODY-ONLY, EXT-PLIST +and NOEXPAND are similar to those used in `org-export-as', which +see. + +Return buffer." + (let ((out (org-export-as + backend subtreep visible-only body-only ext-plist noexpand)) + (buffer (get-buffer-create buffer))) + (with-current-buffer buffer + (erase-buffer) + (insert out) + (goto-char (point-min))) + buffer)) + +(defun org-export-to-file + (backend file &optional subtreep visible-only body-only ext-plist noexpand) + "Call `org-export-as' with output to a specified file. + +BACKEND is the back-end used for transcoding, as a symbol. FILE +is the name of the output file, as a string. + +Optional arguments SUBTREEP, VISIBLE-ONLY, BODY-ONLY, EXT-PLIST +and NOEXPAND are similar to those used in `org-export-as', which +see. + +Return output file's name." + ;; Checks for FILE permissions. `write-file' would do the same, but + ;; we'd rather avoid needless transcoding of parse tree. + (unless (file-writable-p file) (error "Output file not writable")) + ;; Insert contents to a temporary buffer and write it to FILE. + (let ((out (org-export-as + backend subtreep visible-only body-only ext-plist noexpand))) + (with-temp-buffer + (insert out) + (let ((coding-system-for-write org-export-coding-system)) + (write-file file)))) + ;; Return full path. + file) + +(defun org-export-output-file-name (extension &optional subtreep pub-dir) + "Return output file's name according to buffer specifications. + +EXTENSION is a string representing the output file extension, +with the leading dot. + +With a non-nil optional argument SUBTREEP, try to determine +output file's name by looking for \"EXPORT_FILE_NAME\" property +of subtree at point. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +Return file name as a string, or nil if it couldn't be +determined." + (let ((base-name + ;; File name may come from EXPORT_FILE_NAME subtree property, + ;; assuming point is at beginning of said sub-tree. + (file-name-sans-extension + (or (and subtreep + (org-entry-get + (save-excursion + (ignore-errors (org-back-to-heading) (point))) + "EXPORT_FILE_NAME" t)) + ;; File name may be extracted from buffer's associated + ;; file, if any. + (buffer-file-name (buffer-base-buffer)) + ;; Can't determine file name on our own: Ask user. + (let ((read-file-name-function + (and org-completion-use-ido 'ido-read-file-name))) + (read-file-name + "Output file: " pub-dir nil nil nil + (lambda (name) + (string= (file-name-extension name t) extension)))))))) + ;; Build file name. Enforce EXTENSION over whatever user may have + ;; come up with. PUB-DIR, if defined, always has precedence over + ;; any provided path. + (cond + (pub-dir + (concat (file-name-as-directory pub-dir) + (file-name-nondirectory base-name) + extension)) + ((string= (file-name-nondirectory base-name) base-name) + (concat (file-name-as-directory ".") base-name extension)) + (t (concat base-name extension))))) + +(defmacro org-export-with-current-buffer-copy (&rest body) + "Apply BODY in a copy of the current buffer. + +The copy preserves local variables and visibility of the original +buffer. + +Point is at buffer's beginning when BODY is applied." + (org-with-gensyms (original-buffer offset buffer-string overlays) + `(let ((,original-buffer (current-buffer)) + (,offset (1- (point-min))) + (,buffer-string (buffer-string)) + (,overlays (mapcar + 'copy-overlay (overlays-in (point-min) (point-max))))) + (with-temp-buffer + (let ((buffer-invisibility-spec nil)) + (org-clone-local-variables + ,original-buffer + "^\\(org-\\|orgtbl-\\|major-mode$\\|outline-\\(regexp\\|level\\)$\\)") + (insert ,buffer-string) + (mapc (lambda (ov) + (move-overlay + ov + (- (overlay-start ov) ,offset) + (- (overlay-end ov) ,offset) + (current-buffer))) + ,overlays) + (goto-char (point-min)) + (progn ,@body)))))) +(def-edebug-spec org-export-with-current-buffer-copy (body)) + +(defun org-export-expand-include-keyword (&optional included dir) + "Expand every include keyword in buffer. +Optional argument INCLUDED is a list of included file names along +with their line restriction, when appropriate. It is used to +avoid infinite recursion. Optional argument DIR is the current +working directory. It is used to properly resolve relative +paths." + (let ((case-fold-search t)) + (goto-char (point-min)) + (while (re-search-forward "^[ \t]*#\\+INCLUDE: \\(.*\\)" nil t) + (when (eq (org-element-type (save-match-data (org-element-at-point))) + 'keyword) + (beginning-of-line) + ;; Extract arguments from keyword's value. + (let* ((value (match-string 1)) + (ind (org-get-indentation)) + (file (and (string-match "^\"\\(\\S-+\\)\"" value) + (prog1 (expand-file-name (match-string 1 value) dir) + (setq value (replace-match "" nil nil value))))) + (lines + (and (string-match + ":lines +\"\\(\\(?:[0-9]+\\)?-\\(?:[0-9]+\\)?\\)\"" value) + (prog1 (match-string 1 value) + (setq value (replace-match "" nil nil value))))) + (env (cond ((string-match "\\<example\\>" value) 'example) + ((string-match "\\<src\\(?: +\\(.*\\)\\)?" value) + (match-string 1 value)))) + ;; Minimal level of included file defaults to the child + ;; level of the current headline, if any, or one. It + ;; only applies is the file is meant to be included as + ;; an Org one. + (minlevel + (and (not env) + (if (string-match ":minlevel +\\([0-9]+\\)" value) + (prog1 (string-to-number (match-string 1 value)) + (setq value (replace-match "" nil nil value))) + (let ((cur (org-current-level))) + (if cur (1+ (org-reduced-level cur)) 1)))))) + ;; Remove keyword. + (delete-region (point) (progn (forward-line) (point))) + (cond + ((not (file-readable-p file)) (error "Cannot include file %s" file)) + ;; Check if files has already been parsed. Look after + ;; inclusion lines too, as different parts of the same file + ;; can be included too. + ((member (list file lines) included) + (error "Recursive file inclusion: %s" file)) + (t + (cond + ((eq env 'example) + (insert + (let ((ind-str (make-string ind ? )) + (contents + ;; Protect sensitive contents with commas. + (replace-regexp-in-string + "\\(^\\)\\([*]\\|[ \t]*#\\+\\)" "," + (org-export--prepare-file-contents file lines) + nil nil 1))) + (format "%s#+BEGIN_EXAMPLE\n%s%s#+END_EXAMPLE\n" + ind-str contents ind-str)))) + ((stringp env) + (insert + (let ((ind-str (make-string ind ? )) + (contents + ;; Protect sensitive contents with commas. + (replace-regexp-in-string + (if (string= env "org") "\\(^\\)\\(.\\)" + "\\(^\\)\\([*]\\|[ \t]*#\\+\\)") "," + (org-export--prepare-file-contents file lines) + nil nil 1))) + (format "%s#+BEGIN_SRC %s\n%s%s#+END_SRC\n" + ind-str env contents ind-str)))) + (t + (insert + (with-temp-buffer + (org-mode) + (insert + (org-export--prepare-file-contents file lines ind minlevel)) + (org-export-expand-include-keyword + (cons (list file lines) included) + (file-name-directory file)) + (buffer-string)))))))))))) + +(defun org-export--prepare-file-contents (file &optional lines ind minlevel) + "Prepare the contents of FILE for inclusion and return them as a string. + +When optional argument LINES is a string specifying a range of +lines, include only those lines. + +Optional argument IND, when non-nil, is an integer specifying the +global indentation of returned contents. Since its purpose is to +allow an included file to stay in the same environment it was +created \(i.e. a list item), it doesn't apply past the first +headline encountered. + +Optional argument MINLEVEL, when non-nil, is an integer +specifying the level that any top-level headline in the included +file should have." + (with-temp-buffer + (insert-file-contents file) + (when lines + (let* ((lines (split-string lines "-")) + (lbeg (string-to-number (car lines))) + (lend (string-to-number (cadr lines))) + (beg (if (zerop lbeg) (point-min) + (goto-char (point-min)) + (forward-line (1- lbeg)) + (point))) + (end (if (zerop lend) (point-max) + (goto-char (point-min)) + (forward-line (1- lend)) + (point)))) + (narrow-to-region beg end))) + ;; Remove blank lines at beginning and end of contents. The logic + ;; behind that removal is that blank lines around include keyword + ;; override blank lines in included file. + (goto-char (point-min)) + (org-skip-whitespace) + (beginning-of-line) + (delete-region (point-min) (point)) + (goto-char (point-max)) + (skip-chars-backward " \r\t\n") + (forward-line) + (delete-region (point) (point-max)) + ;; If IND is set, preserve indentation of include keyword until + ;; the first headline encountered. + (when ind + (unless (eq major-mode 'org-mode) (org-mode)) + (goto-char (point-min)) + (let ((ind-str (make-string ind ? ))) + (while (not (or (eobp) (looking-at org-outline-regexp-bol))) + ;; Do not move footnote definitions out of column 0. + (unless (and (looking-at org-footnote-definition-re) + (eq (org-element-type (org-element-at-point)) + 'footnote-definition)) + (insert ind-str)) + (forward-line)))) + ;; When MINLEVEL is specified, compute minimal level for headlines + ;; in the file (CUR-MIN), and remove stars to each headline so + ;; that headlines with minimal level have a level of MINLEVEL. + (when minlevel + (unless (eq major-mode 'org-mode) (org-mode)) + (let ((levels (org-map-entries + (lambda () (org-reduced-level (org-current-level)))))) + (when levels + (let ((offset (- minlevel (apply 'min levels)))) + (unless (zerop offset) + (when org-odd-levels-only (setq offset (* offset 2))) + ;; Only change stars, don't bother moving whole + ;; sections. + (org-map-entries + (lambda () (if (< offset 0) (delete-char (abs offset)) + (insert (make-string offset ?*)))))))))) + (buffer-string))) + + +;;; Tools For Back-Ends +;; +;; A whole set of tools is available to help build new exporters. Any +;; function general enough to have its use across many back-ends +;; should be added here. +;; +;; As of now, functions operating on footnotes, headlines, links, +;; macros, references, src-blocks, tables and tables of contents are +;; implemented. + +;;;; For Affiliated Keywords +;; +;; `org-export-read-attribute' reads a property from a given element +;; as a plist. It can be used to normalize affiliated keywords' +;; syntax. + +(defun org-export-read-attribute (attribute element &optional property) + "Turn ATTRIBUTE property from ELEMENT into a plist. + +When optional argument PROPERTY is non-nil, return the value of +that property within attributes. + +This function assumes attributes are defined as \":keyword +value\" pairs. It is appropriate for `:attr_html' like +properties." + (let ((attributes + (let ((value (org-element-property attribute element))) + (and value + (read (format "(%s)" (mapconcat 'identity value " "))))))) + (if property (plist-get attributes property) attributes))) + + +;;;; For Export Snippets +;; +;; Every export snippet is transmitted to the back-end. Though, the +;; latter will only retain one type of export-snippet, ignoring +;; others, based on the former's target back-end. The function +;; `org-export-snippet-backend' returns that back-end for a given +;; export-snippet. + +(defun org-export-snippet-backend (export-snippet) + "Return EXPORT-SNIPPET targeted back-end as a symbol. +Translation, with `org-export-snippet-translation-alist', is +applied." + (let ((back-end (org-element-property :back-end export-snippet))) + (intern + (or (cdr (assoc back-end org-export-snippet-translation-alist)) + back-end)))) + + +;;;; For Footnotes +;; +;; `org-export-collect-footnote-definitions' is a tool to list +;; actually used footnotes definitions in the whole parse tree, or in +;; an headline, in order to add footnote listings throughout the +;; transcoded data. +;; +;; `org-export-footnote-first-reference-p' is a predicate used by some +;; back-ends, when they need to attach the footnote definition only to +;; the first occurrence of the corresponding label. +;; +;; `org-export-get-footnote-definition' and +;; `org-export-get-footnote-number' provide easier access to +;; additional information relative to a footnote reference. + +(defun org-export-collect-footnote-definitions (data info) + "Return an alist between footnote numbers, labels and definitions. + +DATA is the parse tree from which definitions are collected. +INFO is the plist used as a communication channel. + +Definitions are sorted by order of references. They either +appear as Org data or as a secondary string for inlined +footnotes. Unreferenced definitions are ignored." + (let* (num-alist + collect-fn ; for byte-compiler. + (collect-fn + (function + (lambda (data) + ;; Collect footnote number, label and definition in DATA. + (org-element-map + data 'footnote-reference + (lambda (fn) + (when (org-export-footnote-first-reference-p fn info) + (let ((def (org-export-get-footnote-definition fn info))) + (push + (list (org-export-get-footnote-number fn info) + (org-element-property :label fn) + def) + num-alist) + ;; Also search in definition for nested footnotes. + (when (eq (org-element-property :type fn) 'standard) + (funcall collect-fn def))))) + ;; Don't enter footnote definitions since it will happen + ;; when their first reference is found. + info nil 'footnote-definition))))) + (funcall collect-fn (plist-get info :parse-tree)) + (reverse num-alist))) + +(defun org-export-footnote-first-reference-p (footnote-reference info) + "Non-nil when a footnote reference is the first one for its label. + +FOOTNOTE-REFERENCE is the footnote reference being considered. +INFO is the plist used as a communication channel." + (let ((label (org-element-property :label footnote-reference))) + ;; Anonymous footnotes are always a first reference. + (if (not label) t + ;; Otherwise, return the first footnote with the same LABEL and + ;; test if it is equal to FOOTNOTE-REFERENCE. + (let* (search-refs ; for byte-compiler. + (search-refs + (function + (lambda (data) + (org-element-map + data 'footnote-reference + (lambda (fn) + (cond + ((string= (org-element-property :label fn) label) + (throw 'exit fn)) + ;; If FN isn't inlined, be sure to traverse its + ;; definition before resuming search. See + ;; comments in `org-export-get-footnote-number' + ;; for more information. + ((eq (org-element-property :type fn) 'standard) + (funcall search-refs + (org-export-get-footnote-definition fn info))))) + ;; Don't enter footnote definitions since it will + ;; happen when their first reference is found. + info 'first-match 'footnote-definition))))) + (eq (catch 'exit (funcall search-refs (plist-get info :parse-tree))) + footnote-reference))))) + +(defun org-export-get-footnote-definition (footnote-reference info) + "Return definition of FOOTNOTE-REFERENCE as parsed data. +INFO is the plist used as a communication channel." + (let ((label (org-element-property :label footnote-reference))) + (or (org-element-property :inline-definition footnote-reference) + (cdr (assoc label (plist-get info :footnote-definition-alist)))))) + +(defun org-export-get-footnote-number (footnote info) + "Return number associated to a footnote. + +FOOTNOTE is either a footnote reference or a footnote definition. +INFO is the plist used as a communication channel." + (let* ((label (org-element-property :label footnote)) + seen-refs + search-ref ; For byte-compiler. + (search-ref + (function + (lambda (data) + ;; Search footnote references through DATA, filling + ;; SEEN-REFS along the way. + (org-element-map + data 'footnote-reference + (lambda (fn) + (let ((fn-lbl (org-element-property :label fn))) + (cond + ;; Anonymous footnote match: return number. + ((and (not fn-lbl) (eq fn footnote)) + (throw 'exit (1+ (length seen-refs)))) + ;; Labels match: return number. + ((and label (string= label fn-lbl)) + (throw 'exit (1+ (length seen-refs)))) + ;; Anonymous footnote: it's always a new one. Also, + ;; be sure to return nil from the `cond' so + ;; `first-match' doesn't get us out of the loop. + ((not fn-lbl) (push 'inline seen-refs) nil) + ;; Label not seen so far: add it so SEEN-REFS. + ;; + ;; Also search for subsequent references in + ;; footnote definition so numbering follows reading + ;; logic. Note that we don't have to care about + ;; inline definitions, since `org-element-map' + ;; already traverses them at the right time. + ;; + ;; Once again, return nil to stay in the loop. + ((not (member fn-lbl seen-refs)) + (push fn-lbl seen-refs) + (funcall search-ref + (org-export-get-footnote-definition fn info)) + nil)))) + ;; Don't enter footnote definitions since it will happen + ;; when their first reference is found. + info 'first-match 'footnote-definition))))) + (catch 'exit (funcall search-ref (plist-get info :parse-tree))))) + + +;;;; For Headlines +;; +;; `org-export-get-relative-level' is a shortcut to get headline +;; level, relatively to the lower headline level in the parsed tree. +;; +;; `org-export-get-headline-number' returns the section number of an +;; headline, while `org-export-number-to-roman' allows to convert it +;; to roman numbers. +;; +;; `org-export-low-level-p', `org-export-first-sibling-p' and +;; `org-export-last-sibling-p' are three useful predicates when it +;; comes to fulfill the `:headline-levels' property. + +(defun org-export-get-relative-level (headline info) + "Return HEADLINE relative level within current parsed tree. +INFO is a plist holding contextual information." + (+ (org-element-property :level headline) + (or (plist-get info :headline-offset) 0))) + +(defun org-export-low-level-p (headline info) + "Non-nil when HEADLINE is considered as low level. + +INFO is a plist used as a communication channel. + +A low level headlines has a relative level greater than +`:headline-levels' property value. + +Return value is the difference between HEADLINE relative level +and the last level being considered as high enough, or nil." + (let ((limit (plist-get info :headline-levels))) + (when (wholenump limit) + (let ((level (org-export-get-relative-level headline info))) + (and (> level limit) (- level limit)))))) + +(defun org-export-get-headline-number (headline info) + "Return HEADLINE numbering as a list of numbers. +INFO is a plist holding contextual information." + (cdr (assoc headline (plist-get info :headline-numbering)))) + +(defun org-export-numbered-headline-p (headline info) + "Return a non-nil value if HEADLINE element should be numbered. +INFO is a plist used as a communication channel." + (let ((sec-num (plist-get info :section-numbers)) + (level (org-export-get-relative-level headline info))) + (if (wholenump sec-num) (<= level sec-num) sec-num))) + +(defun org-export-number-to-roman (n) + "Convert integer N into a roman numeral." + (let ((roman '((1000 . "M") (900 . "CM") (500 . "D") (400 . "CD") + ( 100 . "C") ( 90 . "XC") ( 50 . "L") ( 40 . "XL") + ( 10 . "X") ( 9 . "IX") ( 5 . "V") ( 4 . "IV") + ( 1 . "I"))) + (res "")) + (if (<= n 0) + (number-to-string n) + (while roman + (if (>= n (caar roman)) + (setq n (- n (caar roman)) + res (concat res (cdar roman))) + (pop roman))) + res))) + +(defun org-export-get-tags (element info &optional tags) + "Return list of tags associated to ELEMENT. + +ELEMENT has either an `headline' or an `inlinetask' type. INFO +is a plist used as a communication channel. + +Select tags (see `org-export-select-tags') and exclude tags (see +`org-export-exclude-tags') are removed from the list. + +When non-nil, optional argument TAGS should be a list of strings. +Any tag belonging to this list will also be removed." + (org-remove-if (lambda (tag) (or (member tag (plist-get info :select-tags)) + (member tag (plist-get info :exclude-tags)) + (member tag tags))) + (org-element-property :tags element))) + +(defun org-export-first-sibling-p (headline info) + "Non-nil when HEADLINE is the first sibling in its sub-tree. +INFO is a plist used as a communication channel." + (not (eq (org-element-type (org-export-get-previous-element headline info)) + 'headline))) + +(defun org-export-last-sibling-p (headline info) + "Non-nil when HEADLINE is the last sibling in its sub-tree. +INFO is a plist used as a communication channel." + (not (org-export-get-next-element headline info))) + + +;;;; For Links +;; +;; `org-export-solidify-link-text' turns a string into a safer version +;; for links, replacing most non-standard characters with hyphens. +;; +;; `org-export-get-coderef-format' returns an appropriate format +;; string for coderefs. +;; +;; `org-export-inline-image-p' returns a non-nil value when the link +;; provided should be considered as an inline image. +;; +;; `org-export-resolve-fuzzy-link' searches destination of fuzzy links +;; (i.e. links with "fuzzy" as type) within the parsed tree, and +;; returns an appropriate unique identifier when found, or nil. +;; +;; `org-export-resolve-id-link' returns the first headline with +;; specified id or custom-id in parse tree, the path to the external +;; file with the id or nil when neither was found. +;; +;; `org-export-resolve-coderef' associates a reference to a line +;; number in the element it belongs, or returns the reference itself +;; when the element isn't numbered. + +(defun org-export-solidify-link-text (s) + "Take link text S and make a safe target out of it." + (save-match-data + (mapconcat 'identity (org-split-string s "[^a-zA-Z0-9_.-]+") "-"))) + +(defun org-export-get-coderef-format (path desc) + "Return format string for code reference link. +PATH is the link path. DESC is its description." + (save-match-data + (cond ((not desc) "%s") + ((string-match (regexp-quote (concat "(" path ")")) desc) + (replace-match "%s" t t desc)) + (t desc)))) + +(defun org-export-inline-image-p (link &optional rules) + "Non-nil if LINK object points to an inline image. + +Optional argument is a set of RULES defining inline images. It +is an alist where associations have the following shape: + + \(TYPE . REGEXP) + +Applying a rule means apply REGEXP against LINK's path when its +type is TYPE. The function will return a non-nil value if any of +the provided rules is non-nil. The default rule is +`org-export-default-inline-image-rule'. + +This only applies to links without a description." + (and (not (org-element-contents link)) + (let ((case-fold-search t) + (rules (or rules org-export-default-inline-image-rule))) + (catch 'exit + (mapc + (lambda (rule) + (and (string= (org-element-property :type link) (car rule)) + (string-match (cdr rule) + (org-element-property :path link)) + (throw 'exit t))) + rules) + ;; Return nil if no rule matched. + nil)))) + +(defun org-export-resolve-coderef (ref info) + "Resolve a code reference REF. + +INFO is a plist used as a communication channel. + +Return associated line number in source code, or REF itself, +depending on src-block or example element's switches." + (org-element-map + (plist-get info :parse-tree) '(example-block src-block) + (lambda (el) + (with-temp-buffer + (insert (org-trim (org-element-property :value el))) + (let* ((label-fmt (regexp-quote + (or (org-element-property :label-fmt el) + org-coderef-label-format))) + (ref-re + (format "^.*?\\S-.*?\\([ \t]*\\(%s\\)\\)[ \t]*$" + (replace-regexp-in-string "%s" ref label-fmt nil t)))) + ;; Element containing REF is found. Resolve it to either + ;; a label or a line number, as needed. + (when (re-search-backward ref-re nil t) + (cond + ((org-element-property :use-labels el) ref) + ((eq (org-element-property :number-lines el) 'continued) + (+ (org-export-get-loc el info) (line-number-at-pos))) + (t (line-number-at-pos))))))) + info 'first-match)) + +(defun org-export-resolve-fuzzy-link (link info) + "Return LINK destination. + +INFO is a plist holding contextual information. + +Return value can be an object, an element, or nil: + +- If LINK path matches a target object (i.e. <<path>>) or + element (i.e. \"#+TARGET: path\"), return it. + +- If LINK path exactly matches the name affiliated keyword + \(i.e. #+NAME: path) of an element, return that element. + +- If LINK path exactly matches any headline name, return that + element. If more than one headline share that name, priority + will be given to the one with the closest common ancestor, if + any, or the first one in the parse tree otherwise. + +- Otherwise, return nil. + +Assume LINK type is \"fuzzy\"." + (let* ((path (org-element-property :path link)) + (match-title-p (eq (aref path 0) ?*))) + (cond + ;; First try to find a matching "<<path>>" unless user specified + ;; he was looking for an headline (path starts with a * + ;; character). + ((and (not match-title-p) + (loop for target in (plist-get info :target-list) + when (string= (org-element-property :value target) path) + return target))) + ;; Then try to find an element with a matching "#+NAME: path" + ;; affiliated keyword. + ((and (not match-title-p) + (org-element-map + (plist-get info :parse-tree) org-element-all-elements + (lambda (el) + (when (string= (org-element-property :name el) path) el)) + info 'first-match))) + ;; Last case: link either points to an headline or to + ;; nothingness. Try to find the source, with priority given to + ;; headlines with the closest common ancestor. If such candidate + ;; is found, return it, otherwise return nil. + (t + (let ((find-headline + (function + ;; Return first headline whose `:raw-value' property + ;; is NAME in parse tree DATA, or nil. + (lambda (name data) + (org-element-map + data 'headline + (lambda (headline) + (when (string= + (org-element-property :raw-value headline) + name) + headline)) + info 'first-match))))) + ;; Search among headlines sharing an ancestor with link, + ;; from closest to farthest. + (or (catch 'exit + (mapc + (lambda (parent) + (when (eq (org-element-type parent) 'headline) + (let ((foundp (funcall find-headline path parent))) + (when foundp (throw 'exit foundp))))) + (org-export-get-genealogy link)) nil) + ;; No match with a common ancestor: try the full parse-tree. + (funcall find-headline + (if match-title-p (substring path 1) path) + (plist-get info :parse-tree)))))))) + +(defun org-export-resolve-id-link (link info) + "Return headline referenced as LINK destination. + +INFO is a plist used as a communication channel. + +Return value can be the headline element matched in current parse +tree, a file name or nil. Assume LINK type is either \"id\" or +\"custom-id\"." + (let ((id (org-element-property :path link))) + ;; First check if id is within the current parse tree. + (or (org-element-map + (plist-get info :parse-tree) 'headline + (lambda (headline) + (when (or (string= (org-element-property :id headline) id) + (string= (org-element-property :custom-id headline) id)) + headline)) + info 'first-match) + ;; Otherwise, look for external files. + (cdr (assoc id (plist-get info :id-alist)))))) + +(defun org-export-resolve-radio-link (link info) + "Return radio-target object referenced as LINK destination. + +INFO is a plist used as a communication channel. + +Return value can be a radio-target object or nil. Assume LINK +has type \"radio\"." + (let ((path (org-element-property :path link))) + (org-element-map + (plist-get info :parse-tree) 'radio-target + (lambda (radio) + (when (equal (org-element-property :value radio) path) radio)) + info 'first-match))) + + +;;;; For Macros +;; +;; `org-export-expand-macro' simply takes care of expanding macros. + +(defun org-export-expand-macro (macro info) + "Expand MACRO and return it as a string. +INFO is a plist holding export options." + (let* ((key (org-element-property :key macro)) + (args (org-element-property :args macro)) + ;; User's macros are stored in the communication channel with + ;; a ":macro-" prefix. Replace arguments in VALUE. Also + ;; expand recursively macros within. + (value (org-export-data + (mapcar + (lambda (obj) + (if (not (stringp obj)) (org-export-data obj info) + (replace-regexp-in-string + "\\$[0-9]+" + (lambda (arg) + (nth (1- (string-to-number (substring arg 1))) args)) + obj))) + (plist-get info (intern (format ":macro-%s" key)))) + info))) + ;; VALUE starts with "(eval": it is a s-exp, `eval' it. + (when (string-match "\\`(eval\\>" value) (setq value (eval (read value)))) + ;; Return string. + (format "%s" (or value "")))) + + +;;;; For References +;; +;; `org-export-get-ordinal' associates a sequence number to any object +;; or element. + +(defun org-export-get-ordinal (element info &optional types predicate) + "Return ordinal number of an element or object. + +ELEMENT is the element or object considered. INFO is the plist +used as a communication channel. + +Optional argument TYPES, when non-nil, is a list of element or +object types, as symbols, that should also be counted in. +Otherwise, only provided element's type is considered. + +Optional argument PREDICATE is a function returning a non-nil +value if the current element or object should be counted in. It +accepts two arguments: the element or object being considered and +the plist used as a communication channel. This allows to count +only a certain type of objects (i.e. inline images). + +Return value is a list of numbers if ELEMENT is an headline or an +item. It is nil for keywords. It represents the footnote number +for footnote definitions and footnote references. If ELEMENT is +a target, return the same value as if ELEMENT was the closest +table, item or headline containing the target. In any other +case, return the sequence number of ELEMENT among elements or +objects of the same type." + ;; A target keyword, representing an invisible target, never has + ;; a sequence number. + (unless (eq (org-element-type element) 'keyword) + ;; Ordinal of a target object refer to the ordinal of the closest + ;; table, item, or headline containing the object. + (when (eq (org-element-type element) 'target) + (setq element + (loop for parent in (org-export-get-genealogy element) + when + (memq + (org-element-type parent) + '(footnote-definition footnote-reference headline item + table)) + return parent))) + (case (org-element-type element) + ;; Special case 1: An headline returns its number as a list. + (headline (org-export-get-headline-number element info)) + ;; Special case 2: An item returns its number as a list. + (item (let ((struct (org-element-property :structure element))) + (org-list-get-item-number + (org-element-property :begin element) + struct + (org-list-prevs-alist struct) + (org-list-parents-alist struct)))) + ((footnote-definition footnote-reference) + (org-export-get-footnote-number element info)) + (otherwise + (let ((counter 0)) + ;; Increment counter until ELEMENT is found again. + (org-element-map + (plist-get info :parse-tree) (or types (org-element-type element)) + (lambda (el) + (cond + ((eq element el) (1+ counter)) + ((not predicate) (incf counter) nil) + ((funcall predicate el info) (incf counter) nil))) + info 'first-match)))))) + + +;;;; For Src-Blocks +;; +;; `org-export-get-loc' counts number of code lines accumulated in +;; src-block or example-block elements with a "+n" switch until +;; a given element, excluded. Note: "-n" switches reset that count. +;; +;; `org-export-unravel-code' extracts source code (along with a code +;; references alist) from an `element-block' or `src-block' type +;; element. +;; +;; `org-export-format-code' applies a formatting function to each line +;; of code, providing relative line number and code reference when +;; appropriate. Since it doesn't access the original element from +;; which the source code is coming, it expects from the code calling +;; it to know if lines should be numbered and if code references +;; should appear. +;; +;; Eventually, `org-export-format-code-default' is a higher-level +;; function (it makes use of the two previous functions) which handles +;; line numbering and code references inclusion, and returns source +;; code in a format suitable for plain text or verbatim output. + +(defun org-export-get-loc (element info) + "Return accumulated lines of code up to ELEMENT. + +INFO is the plist used as a communication channel. + +ELEMENT is excluded from count." + (let ((loc 0)) + (org-element-map + (plist-get info :parse-tree) + `(src-block example-block ,(org-element-type element)) + (lambda (el) + (cond + ;; ELEMENT is reached: Quit the loop. + ((eq el element)) + ;; Only count lines from src-block and example-block elements + ;; with a "+n" or "-n" switch. A "-n" switch resets counter. + ((not (memq (org-element-type el) '(src-block example-block))) nil) + ((let ((linums (org-element-property :number-lines el))) + (when linums + ;; Accumulate locs or reset them. + (let ((lines (org-count-lines + (org-trim (org-element-property :value el))))) + (setq loc (if (eq linums 'new) lines (+ loc lines)))))) + ;; Return nil to stay in the loop. + nil))) + info 'first-match) + ;; Return value. + loc)) + +(defun org-export-unravel-code (element) + "Clean source code and extract references out of it. + +ELEMENT has either a `src-block' an `example-block' type. + +Return a cons cell whose CAR is the source code, cleaned from any +reference and protective comma and CDR is an alist between +relative line number (integer) and name of code reference on that +line (string)." + (let* ((line 0) refs + ;; Get code and clean it. Remove blank lines at its + ;; beginning and end. Also remove protective commas. + (code (let ((c (replace-regexp-in-string + "\\`\\([ \t]*\n\\)+" "" + (replace-regexp-in-string + "\\(:?[ \t]*\n\\)*[ \t]*\\'" "\n" + (org-element-property :value element))))) + ;; If appropriate, remove global indentation. + (unless (or org-src-preserve-indentation + (org-element-property :preserve-indent element)) + (setq c (org-remove-indentation c))) + ;; Free up the protected lines. Note: Org blocks + ;; have commas at the beginning or every line. + (if (string= (org-element-property :language element) "org") + (replace-regexp-in-string "^," "" c) + (replace-regexp-in-string + "^\\(,\\)\\(:?\\*\\|[ \t]*#\\+\\)" "" c nil nil 1)))) + ;; Get format used for references. + (label-fmt (regexp-quote + (or (org-element-property :label-fmt element) + org-coderef-label-format))) + ;; Build a regexp matching a loc with a reference. + (with-ref-re + (format "^.*?\\S-.*?\\([ \t]*\\(%s\\)[ \t]*\\)$" + (replace-regexp-in-string + "%s" "\\([-a-zA-Z0-9_ ]+\\)" label-fmt nil t)))) + ;; Return value. + (cons + ;; Code with references removed. + (org-element-normalize-string + (mapconcat + (lambda (loc) + (incf line) + (if (not (string-match with-ref-re loc)) loc + ;; Ref line: remove ref, and signal its position in REFS. + (push (cons line (match-string 3 loc)) refs) + (replace-match "" nil nil loc 1))) + (org-split-string code "\n") "\n")) + ;; Reference alist. + refs))) + +(defun org-export-format-code (code fun &optional num-lines ref-alist) + "Format CODE by applying FUN line-wise and return it. + +CODE is a string representing the code to format. FUN is +a function. It must accept three arguments: a line of +code (string), the current line number (integer) or nil and the +reference associated to the current line (string) or nil. + +Optional argument NUM-LINES can be an integer representing the +number of code lines accumulated until the current code. Line +numbers passed to FUN will take it into account. If it is nil, +FUN's second argument will always be nil. This number can be +obtained with `org-export-get-loc' function. + +Optional argument REF-ALIST can be an alist between relative line +number (i.e. ignoring NUM-LINES) and the name of the code +reference on it. If it is nil, FUN's third argument will always +be nil. It can be obtained through the use of +`org-export-unravel-code' function." + (let ((--locs (org-split-string code "\n")) + (--line 0)) + (org-element-normalize-string + (mapconcat + (lambda (--loc) + (incf --line) + (let ((--ref (cdr (assq --line ref-alist)))) + (funcall fun --loc (and num-lines (+ num-lines --line)) --ref))) + --locs "\n")))) + +(defun org-export-format-code-default (element info) + "Return source code from ELEMENT, formatted in a standard way. + +ELEMENT is either a `src-block' or `example-block' element. INFO +is a plist used as a communication channel. + +This function takes care of line numbering and code references +inclusion. Line numbers, when applicable, appear at the +beginning of the line, separated from the code by two white +spaces. Code references, on the other hand, appear flushed to +the right, separated by six white spaces from the widest line of +code." + ;; Extract code and references. + (let* ((code-info (org-export-unravel-code element)) + (code (car code-info)) + (code-lines (org-split-string code "\n")) + (refs (and (org-element-property :retain-labels element) + (cdr code-info))) + ;; Handle line numbering. + (num-start (case (org-element-property :number-lines element) + (continued (org-export-get-loc element info)) + (new 0))) + (num-fmt + (and num-start + (format "%%%ds " + (length (number-to-string + (+ (length code-lines) num-start)))))) + ;; Prepare references display, if required. Any reference + ;; should start six columns after the widest line of code, + ;; wrapped with parenthesis. + (max-width + (+ (apply 'max (mapcar 'length code-lines)) + (if (not num-start) 0 (length (format num-fmt num-start)))))) + (org-export-format-code + code + (lambda (loc line-num ref) + (let ((number-str (and num-fmt (format num-fmt line-num)))) + (concat + number-str + loc + (and ref + (concat (make-string + (- (+ 6 max-width) + (+ (length loc) (length number-str))) ? ) + (format "(%s)" ref)))))) + num-start refs))) + + +;;;; For Tables +;; +;; `org-export-table-has-special-column-p' and and +;; `org-export-table-row-is-special-p' are predicates used to look for +;; meta-information about the table structure. +;; +;; `org-table-has-header-p' tells when the rows before the first rule +;; should be considered as table's header. +;; +;; `org-export-table-cell-width', `org-export-table-cell-alignment' +;; and `org-export-table-cell-borders' extract information from +;; a table-cell element. +;; +;; `org-export-table-dimensions' gives the number on rows and columns +;; in the table, ignoring horizontal rules and special columns. +;; `org-export-table-cell-address', given a table-cell object, returns +;; the absolute address of a cell. On the other hand, +;; `org-export-get-table-cell-at' does the contrary. +;; +;; `org-export-table-cell-starts-colgroup-p', +;; `org-export-table-cell-ends-colgroup-p', +;; `org-export-table-row-starts-rowgroup-p', +;; `org-export-table-row-ends-rowgroup-p', +;; `org-export-table-row-starts-header-p' and +;; `org-export-table-row-ends-header-p' indicate position of current +;; row or cell within the table. + +(defun org-export-table-has-special-column-p (table) + "Non-nil when TABLE has a special column. +All special columns will be ignored during export." + ;; The table has a special column when every first cell of every row + ;; has an empty value or contains a symbol among "/", "#", "!", "$", + ;; "*" "_" and "^". Though, do not consider a first row containing + ;; only empty cells as special. + (let ((special-column-p 'empty)) + (catch 'exit + (mapc + (lambda (row) + (when (eq (org-element-property :type row) 'standard) + (let ((value (org-element-contents + (car (org-element-contents row))))) + (cond ((member value '(("/") ("#") ("!") ("$") ("*") ("_") ("^"))) + (setq special-column-p 'special)) + ((not value)) + (t (throw 'exit nil)))))) + (org-element-contents table)) + (eq special-column-p 'special)))) + +(defun org-export-table-has-header-p (table info) + "Non-nil when TABLE has an header. + +INFO is a plist used as a communication channel. + +A table has an header when it contains at least two row groups." + (let ((rowgroup 1) row-flag) + (org-element-map + table 'table-row + (lambda (row) + (cond + ((> rowgroup 1) t) + ((and row-flag (eq (org-element-property :type row) 'rule)) + (incf rowgroup) (setq row-flag nil)) + ((and (not row-flag) (eq (org-element-property :type row) 'standard)) + (setq row-flag t) nil))) + info))) + +(defun org-export-table-row-is-special-p (table-row info) + "Non-nil if TABLE-ROW is considered special. + +INFO is a plist used as the communication channel. + +All special rows will be ignored during export." + (when (eq (org-element-property :type table-row) 'standard) + (let ((first-cell (org-element-contents + (car (org-element-contents table-row))))) + ;; A row is special either when... + (or + ;; ... it starts with a field only containing "/", + (equal first-cell '("/")) + ;; ... the table contains a special column and the row start + ;; with a marking character among, "^", "_", "$" or "!", + (and (org-export-table-has-special-column-p + (org-export-get-parent table-row)) + (member first-cell '(("^") ("_") ("$") ("!")))) + ;; ... it contains only alignment cookies and empty cells. + (let ((special-row-p 'empty)) + (catch 'exit + (mapc + (lambda (cell) + (let ((value (org-element-contents cell))) + ;; Since VALUE is a secondary string, the following + ;; checks avoid expanding it with `org-export-data'. + (cond ((not value)) + ((and (not (cdr value)) + (stringp (car value)) + (string-match "\\`<[lrc]?\\([0-9]+\\)?>\\'" + (car value))) + (setq special-row-p 'cookie)) + (t (throw 'exit nil))))) + (org-element-contents table-row)) + (eq special-row-p 'cookie))))))) + +(defun org-export-table-row-group (table-row info) + "Return TABLE-ROW's group. + +INFO is a plist used as the communication channel. + +Return value is the group number, as an integer, or nil special +rows and table rules. Group 1 is also table's header." + (unless (or (eq (org-element-property :type table-row) 'rule) + (org-export-table-row-is-special-p table-row info)) + (let ((group 0) row-flag) + (catch 'found + (mapc + (lambda (row) + (cond + ((and (eq (org-element-property :type row) 'standard) + (not (org-export-table-row-is-special-p row info))) + (unless row-flag (incf group) (setq row-flag t))) + ((eq (org-element-property :type row) 'rule) + (setq row-flag nil))) + (when (eq table-row row) (throw 'found group))) + (org-element-contents (org-export-get-parent table-row))))))) + +(defun org-export-table-cell-width (table-cell info) + "Return TABLE-CELL contents width. + +INFO is a plist used as the communication channel. + +Return value is the width given by the last width cookie in the +same column as TABLE-CELL, or nil." + (let* ((row (org-export-get-parent table-cell)) + (column (let ((cells (org-element-contents row))) + (- (length cells) (length (memq table-cell cells))))) + (table (org-export-get-parent-table table-cell)) + cookie-width) + (mapc + (lambda (row) + (cond + ;; In a special row, try to find a width cookie at COLUMN. + ((org-export-table-row-is-special-p row info) + (let ((value (org-element-contents + (elt (org-element-contents row) column)))) + ;; The following checks avoid expanding unnecessarily the + ;; cell with `org-export-data' + (when (and value + (not (cdr value)) + (stringp (car value)) + (string-match "\\`<[lrc]?\\([0-9]+\\)?>\\'" (car value)) + (match-string 1 (car value))) + (setq cookie-width + (string-to-number (match-string 1 (car value))))))) + ;; Ignore table rules. + ((eq (org-element-property :type row) 'rule)))) + (org-element-contents table)) + ;; Return value. + cookie-width)) + +(defun org-export-table-cell-alignment (table-cell info) + "Return TABLE-CELL contents alignment. + +INFO is a plist used as the communication channel. + +Return alignment as specified by the last alignment cookie in the +same column as TABLE-CELL. If no such cookie is found, a default +alignment value will be deduced from fraction of numbers in the +column (see `org-table-number-fraction' for more information). +Possible values are `left', `right' and `center'." + (let* ((row (org-export-get-parent table-cell)) + (column (let ((cells (org-element-contents row))) + (- (length cells) (length (memq table-cell cells))))) + (table (org-export-get-parent-table table-cell)) + (number-cells 0) + (total-cells 0) + cookie-align) + (mapc + (lambda (row) + (cond + ;; In a special row, try to find an alignment cookie at + ;; COLUMN. + ((org-export-table-row-is-special-p row info) + (let ((value (org-element-contents + (elt (org-element-contents row) column)))) + ;; Since VALUE is a secondary string, the following checks + ;; avoid useless expansion through `org-export-data'. + (when (and value + (not (cdr value)) + (stringp (car value)) + (string-match "\\`<\\([lrc]\\)?\\([0-9]+\\)?>\\'" + (car value)) + (match-string 1 (car value))) + (setq cookie-align (match-string 1 (car value)))))) + ;; Ignore table rules. + ((eq (org-element-property :type row) 'rule)) + ;; In a standard row, check if cell's contents are expressing + ;; some kind of number. Increase NUMBER-CELLS accordingly. + ;; Though, don't bother if an alignment cookie has already + ;; defined cell's alignment. + ((not cookie-align) + (let ((value (org-export-data + (org-element-contents + (elt (org-element-contents row) column)) + info))) + (incf total-cells) + (when (string-match org-table-number-regexp value) + (incf number-cells)))))) + (org-element-contents table)) + ;; Return value. Alignment specified by cookies has precedence + ;; over alignment deduced from cells contents. + (cond ((equal cookie-align "l") 'left) + ((equal cookie-align "r") 'right) + ((equal cookie-align "c") 'center) + ((>= (/ (float number-cells) total-cells) org-table-number-fraction) + 'right) + (t 'left)))) + +(defun org-export-table-cell-borders (table-cell info) + "Return TABLE-CELL borders. + +INFO is a plist used as a communication channel. + +Return value is a list of symbols, or nil. Possible values are: +`top', `bottom', `above', `below', `left' and `right'. Note: +`top' (resp. `bottom') only happen for a cell in the first +row (resp. last row) of the table, ignoring table rules, if any. + +Returned borders ignore special rows." + (let* ((row (org-export-get-parent table-cell)) + (table (org-export-get-parent-table table-cell)) + borders) + ;; Top/above border? TABLE-CELL has a border above when a rule + ;; used to demarcate row groups can be found above. Hence, + ;; finding a rule isn't sufficient to push `above' in BORDERS: + ;; another regular row has to be found above that rule. + (let (rule-flag) + (catch 'exit + (mapc (lambda (row) + (cond ((eq (org-element-property :type row) 'rule) + (setq rule-flag t)) + ((not (org-export-table-row-is-special-p row info)) + (if rule-flag (throw 'exit (push 'above borders)) + (throw 'exit nil))))) + ;; Look at every row before the current one. + (cdr (memq row (reverse (org-element-contents table))))) + ;; No rule above, or rule found starts the table (ignoring any + ;; special row): TABLE-CELL is at the top of the table. + (when rule-flag (push 'above borders)) + (push 'top borders))) + ;; Bottom/below border? TABLE-CELL has a border below when next + ;; non-regular row below is a rule. + (let (rule-flag) + (catch 'exit + (mapc (lambda (row) + (cond ((eq (org-element-property :type row) 'rule) + (setq rule-flag t)) + ((not (org-export-table-row-is-special-p row info)) + (if rule-flag (throw 'exit (push 'below borders)) + (throw 'exit nil))))) + ;; Look at every row after the current one. + (cdr (memq row (org-element-contents table)))) + ;; No rule below, or rule found ends the table (modulo some + ;; special row): TABLE-CELL is at the bottom of the table. + (when rule-flag (push 'below borders)) + (push 'bottom borders))) + ;; Right/left borders? They can only be specified by column + ;; groups. Column groups are defined in a row starting with "/". + ;; Also a column groups row only contains "<", "<>", ">" or blank + ;; cells. + (catch 'exit + (let ((column (let ((cells (org-element-contents row))) + (- (length cells) (length (memq table-cell cells)))))) + (mapc + (lambda (row) + (unless (eq (org-element-property :type row) 'rule) + (when (equal (org-element-contents + (car (org-element-contents row))) + '("/")) + (let ((column-groups + (mapcar + (lambda (cell) + (let ((value (org-element-contents cell))) + (when (member value '(("<") ("<>") (">") nil)) + (car value)))) + (org-element-contents row)))) + ;; There's a left border when previous cell, if + ;; any, ends a group, or current one starts one. + (when (or (and (not (zerop column)) + (member (elt column-groups (1- column)) + '(">" "<>"))) + (member (elt column-groups column) '("<" "<>"))) + (push 'left borders)) + ;; There's a right border when next cell, if any, + ;; starts a group, or current one ends one. + (when (or (and (/= (1+ column) (length column-groups)) + (member (elt column-groups (1+ column)) + '("<" "<>"))) + (member (elt column-groups column) '(">" "<>"))) + (push 'right borders)) + (throw 'exit nil))))) + ;; Table rows are read in reverse order so last column groups + ;; row has precedence over any previous one. + (reverse (org-element-contents table))))) + ;; Return value. + borders)) + +(defun org-export-table-cell-starts-colgroup-p (table-cell info) + "Non-nil when TABLE-CELL is at the beginning of a row group. +INFO is a plist used as a communication channel." + ;; A cell starts a column group either when it is at the beginning + ;; of a row (or after the special column, if any) or when it has + ;; a left border. + (or (eq (org-element-map + (org-export-get-parent table-cell) + 'table-cell 'identity info 'first-match) + table-cell) + (memq 'left (org-export-table-cell-borders table-cell info)))) + +(defun org-export-table-cell-ends-colgroup-p (table-cell info) + "Non-nil when TABLE-CELL is at the end of a row group. +INFO is a plist used as a communication channel." + ;; A cell ends a column group either when it is at the end of a row + ;; or when it has a right border. + (or (eq (car (last (org-element-contents + (org-export-get-parent table-cell)))) + table-cell) + (memq 'right (org-export-table-cell-borders table-cell info)))) + +(defun org-export-table-row-starts-rowgroup-p (table-row info) + "Non-nil when TABLE-ROW is at the beginning of a column group. +INFO is a plist used as a communication channel." + (unless (or (eq (org-element-property :type table-row) 'rule) + (org-export-table-row-is-special-p table-row info)) + (let ((borders (org-export-table-cell-borders + (car (org-element-contents table-row)) info))) + (or (memq 'top borders) (memq 'above borders))))) + +(defun org-export-table-row-ends-rowgroup-p (table-row info) + "Non-nil when TABLE-ROW is at the end of a column group. +INFO is a plist used as a communication channel." + (unless (or (eq (org-element-property :type table-row) 'rule) + (org-export-table-row-is-special-p table-row info)) + (let ((borders (org-export-table-cell-borders + (car (org-element-contents table-row)) info))) + (or (memq 'bottom borders) (memq 'below borders))))) + +(defun org-export-table-row-starts-header-p (table-row info) + "Non-nil when TABLE-ROW is the first table header's row. +INFO is a plist used as a communication channel." + (and (org-export-table-has-header-p + (org-export-get-parent-table table-row) info) + (org-export-table-row-starts-rowgroup-p table-row info) + (= (org-export-table-row-group table-row info) 1))) + +(defun org-export-table-row-ends-header-p (table-row info) + "Non-nil when TABLE-ROW is the last table header's row. +INFO is a plist used as a communication channel." + (and (org-export-table-has-header-p + (org-export-get-parent-table table-row) info) + (org-export-table-row-ends-rowgroup-p table-row info) + (= (org-export-table-row-group table-row info) 1))) + +(defun org-export-table-dimensions (table info) + "Return TABLE dimensions. + +INFO is a plist used as a communication channel. + +Return value is a CONS like (ROWS . COLUMNS) where +ROWS (resp. COLUMNS) is the number of exportable +rows (resp. columns)." + (let (first-row (columns 0) (rows 0)) + ;; Set number of rows, and extract first one. + (org-element-map + table 'table-row + (lambda (row) + (when (eq (org-element-property :type row) 'standard) + (incf rows) + (unless first-row (setq first-row row)))) info) + ;; Set number of columns. + (org-element-map first-row 'table-cell (lambda (cell) (incf columns)) info) + ;; Return value. + (cons rows columns))) + +(defun org-export-table-cell-address (table-cell info) + "Return address of a regular TABLE-CELL object. + +TABLE-CELL is the cell considered. INFO is a plist used as +a communication channel. + +Address is a CONS cell (ROW . COLUMN), where ROW and COLUMN are +zero-based index. Only exportable cells are considered. The +function returns nil for other cells." + (let* ((table-row (org-export-get-parent table-cell)) + (table (org-export-get-parent-table table-cell))) + ;; Ignore cells in special rows or in special column. + (unless (or (org-export-table-row-is-special-p table-row info) + (and (org-export-table-has-special-column-p table) + (eq (car (org-element-contents table-row)) table-cell))) + (cons + ;; Row number. + (let ((row-count 0)) + (org-element-map + table 'table-row + (lambda (row) + (cond ((eq (org-element-property :type row) 'rule) nil) + ((eq row table-row) row-count) + (t (incf row-count) nil))) + info 'first-match)) + ;; Column number. + (let ((col-count 0)) + (org-element-map + table-row 'table-cell + (lambda (cell) + (if (eq cell table-cell) col-count (incf col-count) nil)) + info 'first-match)))))) + +(defun org-export-get-table-cell-at (address table info) + "Return regular table-cell object at ADDRESS in TABLE. + +Address is a CONS cell (ROW . COLUMN), where ROW and COLUMN are +zero-based index. TABLE is a table type element. INFO is +a plist used as a communication channel. + +If no table-cell, among exportable cells, is found at ADDRESS, +return nil." + (let ((column-pos (cdr address)) (column-count 0)) + (org-element-map + ;; Row at (car address) or nil. + (let ((row-pos (car address)) (row-count 0)) + (org-element-map + table 'table-row + (lambda (row) + (cond ((eq (org-element-property :type row) 'rule) nil) + ((= row-count row-pos) row) + (t (incf row-count) nil))) + info 'first-match)) + 'table-cell + (lambda (cell) + (if (= column-count column-pos) cell + (incf column-count) nil)) + info 'first-match))) + + +;;;; For Tables Of Contents +;; +;; `org-export-collect-headlines' builds a list of all exportable +;; headline elements, maybe limited to a certain depth. One can then +;; easily parse it and transcode it. +;; +;; Building lists of tables, figures or listings is quite similar. +;; Once the generic function `org-export-collect-elements' is defined, +;; `org-export-collect-tables', `org-export-collect-figures' and +;; `org-export-collect-listings' can be derived from it. + +(defun org-export-collect-headlines (info &optional n) + "Collect headlines in order to build a table of contents. + +INFO is a plist used as a communication channel. + +When optional argument N is an integer, it specifies the depth of +the table of contents. Otherwise, it is set to the value of the +last headline level. See `org-export-headline-levels' for more +information. + +Return a list of all exportable headlines as parsed elements." + (unless (wholenump n) (setq n (plist-get info :headline-levels))) + (org-element-map + (plist-get info :parse-tree) + 'headline + (lambda (headline) + ;; Strip contents from HEADLINE. + (let ((relative-level (org-export-get-relative-level headline info))) + (unless (> relative-level n) headline))) + info)) + +(defun org-export-collect-elements (type info &optional predicate) + "Collect referenceable elements of a determined type. + +TYPE can be a symbol or a list of symbols specifying element +types to search. Only elements with a caption are collected. + +INFO is a plist used as a communication channel. + +When non-nil, optional argument PREDICATE is a function accepting +one argument, an element of type TYPE. It returns a non-nil +value when that element should be collected. + +Return a list of all elements found, in order of appearance." + (org-element-map + (plist-get info :parse-tree) type + (lambda (element) + (and (org-element-property :caption element) + (or (not predicate) (funcall predicate element)) + element)) + info)) + +(defun org-export-collect-tables (info) + "Build a list of tables. +INFO is a plist used as a communication channel. + +Return a list of table elements with a caption." + (org-export-collect-elements 'table info)) + +(defun org-export-collect-figures (info predicate) + "Build a list of figures. + +INFO is a plist used as a communication channel. PREDICATE is +a function which accepts one argument: a paragraph element and +whose return value is non-nil when that element should be +collected. + +A figure is a paragraph type element, with a caption, verifying +PREDICATE. The latter has to be provided since a \"figure\" is +a vague concept that may depend on back-end. + +Return a list of elements recognized as figures." + (org-export-collect-elements 'paragraph info predicate)) + +(defun org-export-collect-listings (info) + "Build a list of src blocks. + +INFO is a plist used as a communication channel. + +Return a list of src-block elements with a caption." + (org-export-collect-elements 'src-block info)) + + +;;;; Topology +;; +;; Here are various functions to retrieve information about the +;; neighbourhood of a given element or object. Neighbours of interest +;; are direct parent (`org-export-get-parent'), parent headline +;; (`org-export-get-parent-headline'), first element containing an +;; object, (`org-export-get-parent-element'), parent table +;; (`org-export-get-parent-table'), previous element or object +;; (`org-export-get-previous-element') and next element or object +;; (`org-export-get-next-element'). +;; +;; `org-export-get-genealogy' returns the full genealogy of a given +;; element or object, from closest parent to full parse tree. + +(defun org-export-get-parent (blob) + "Return BLOB parent or nil. +BLOB is the element or object considered." + (org-element-property :parent blob)) + +(defun org-export-get-genealogy (blob) + "Return full genealogy relative to a given element or object. + +BLOB is the element or object being considered. + +Ancestors are returned from closest to farthest, the last one +being the full parse tree." + (let (genealogy (parent blob)) + (while (setq parent (org-element-property :parent parent)) + (push parent genealogy)) + (nreverse genealogy))) + +(defun org-export-get-parent-headline (blob) + "Return BLOB parent headline or nil. +BLOB is the element or object being considered." + (let ((parent blob)) + (while (and (setq parent (org-element-property :parent parent)) + (not (eq (org-element-type parent) 'headline)))) + parent)) + +(defun org-export-get-parent-element (object) + "Return first element containing OBJECT or nil. +OBJECT is the object to consider." + (let ((parent object)) + (while (and (setq parent (org-element-property :parent parent)) + (memq (org-element-type parent) org-element-all-objects))) + parent)) + +(defun org-export-get-parent-table (object) + "Return OBJECT parent table or nil. +OBJECT is either a `table-cell' or `table-element' type object." + (let ((parent object)) + (while (and (setq parent (org-element-property :parent parent)) + (not (eq (org-element-type parent) 'table)))) + parent)) + +(defun org-export-get-previous-element (blob info) + "Return previous element or object. +BLOB is an element or object. INFO is a plist used as +a communication channel. Return previous exportable element or +object, a string, or nil." + (let (prev) + (catch 'exit + (mapc (lambda (obj) + (cond ((eq obj blob) (throw 'exit prev)) + ((memq obj (plist-get info :ignore-list))) + (t (setq prev obj)))) + (org-element-contents (org-export-get-parent blob)))))) + +(defun org-export-get-next-element (blob info) + "Return next element or object. +BLOB is an element or object. INFO is a plist used as +a communication channel. Return next exportable element or +object, a string, or nil." + (catch 'found + (mapc (lambda (obj) + (unless (memq obj (plist-get info :ignore-list)) + (throw 'found obj))) + (cdr (memq blob (org-element-contents (org-export-get-parent blob))))) + nil)) + + +;;;; Translation +;; +;; `org-export-translate' translates a string according to language +;; specified by LANGUAGE keyword or `org-export-language-setup' +;; variable and a specified charset. `org-export-dictionary' contains +;; the dictionary used for the translation. + +(defconst org-export-dictionary + '(("Author" + ("fr" + :ascii "Auteur" + :latin1 "Auteur" + :utf-8 "Auteur")) + ("Date" + ("fr" + :ascii "Date" + :latin1 "Date" + :utf-8 "Date")) + ("Equation") + ("Figure") + ("Footnotes" + ("fr" + :ascii "Notes de bas de page" + :latin1 "Notes de bas de page" + :utf-8 "Notes de bas de page")) + ("List of Listings" + ("fr" + :ascii "Liste des programmes" + :latin1 "Liste des programmes" + :utf-8 "Liste des programmes")) + ("List of Tables" + ("fr" + :ascii "Liste des tableaux" + :latin1 "Liste des tableaux" + :utf-8 "Liste des tableaux")) + ("Listing %d:" + ("fr" + :ascii "Programme %d :" + :latin1 "Programme %d :" + :utf-8 "Programme nº %d :")) + ("Listing %d: %s" + ("fr" + :ascii "Programme %d : %s" + :latin1 "Programme %d : %s" + :utf-8 "Programme nº %d : %s")) + ("See section %s" + ("fr" + :ascii "cf. section %s" + :latin1 "cf. section %s" + :utf-8 "cf. section %s")) + ("Table %d:" + ("fr" + :ascii "Tableau %d :" + :latin1 "Tableau %d :" + :utf-8 "Tableau nº %d :")) + ("Table %d: %s" + ("fr" + :ascii "Tableau %d : %s" + :latin1 "Tableau %d : %s" + :utf-8 "Tableau nº %d : %s")) + ("Table of Contents" + ("fr" + :ascii "Sommaire" + :latin1 "Table des matières" + :utf-8 "Table des matières")) + ("Unknown reference" + ("fr" + :ascii "Destination inconnue" + :latin1 "Référence inconnue" + :utf-8 "Référence inconnue"))) + "Dictionary for export engine. + +Alist whose CAR is the string to translate and CDR is an alist +whose CAR is the language string and CDR is a plist whose +properties are possible charsets and values translated terms. + +It is used as a database for `org-export-translate'. Since this +function returns the string as-is if no translation was found, +the variable only needs to record values different from the +entry.") + +(defun org-export-translate (s encoding info) + "Translate string S according to language specification. + +ENCODING is a symbol among `:ascii', `:html', `:latex', `:latin1' +and `:utf-8'. INFO is a plist used as a communication channel. + +Translation depends on `:language' property. Return the +translated string. If no translation is found return S." + (let ((lang (plist-get info :language)) + (translations (cdr (assoc s org-export-dictionary)))) + (or (plist-get (cdr (assoc lang translations)) encoding) s))) + + + +;;; The Dispatcher +;; +;; `org-export-dispatch' is the standard interactive way to start an +;; export process. It uses `org-export-dispatch-ui' as a subroutine +;; for its interface. Most commons back-ends should have an entry in +;; it. + +;;;###autoload +(defun org-export-dispatch () + "Export dispatcher for Org mode. + +It provides an access to common export related tasks in a buffer. +Its interface comes in two flavours: standard and expert. While +both share the same set of bindings, only the former displays the +valid keys associations. Set `org-export-dispatch-use-expert-ui' +to switch to one or the other. + +Return an error if key pressed has no associated command." + (interactive) + (let* ((input (org-export-dispatch-ui + (if (listp org-export-initial-scope) org-export-initial-scope + (list org-export-initial-scope)) + org-export-dispatch-use-expert-ui)) + (raw-key (car input)) + (optns (cdr input))) + ;; Translate "C-a", "C-b"... into "a", "b"... Then take action + ;; depending on user's key pressed. + (case (if (< raw-key 27) (+ raw-key 96) raw-key) + ;; Allow to quit with "q" key. + (?q nil) + ;; Export with `e-ascii' back-end. + ((?A ?N ?U) + (org-e-ascii-export-as-ascii + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns) + `(:ascii-charset ,(case raw-key (?A 'ascii) (?N 'latin1) (t 'utf-8))))) + ((?a ?n ?u) + (org-e-ascii-export-to-ascii + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns) + `(:ascii-charset ,(case raw-key (?a 'ascii) (?n 'latin1) (t 'utf-8))))) + ;; Export with `e-latex' back-end. + (?L (org-e-latex-export-as-latex + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?l + (org-e-latex-export-to-latex + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?p + (org-e-latex-export-to-pdf + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?d + (org-open-file + (org-e-latex-export-to-pdf + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns)))) + ;; Export with `e-html' back-end. + (?H + (org-e-html-export-as-html + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?h + (org-e-html-export-to-html + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?b + (org-open-file + (org-e-html-export-to-html + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns)))) + ;; Export with `e-odt' back-end. + (?o + (org-e-odt-export-to-odt + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns))) + (?O + (org-open-file + (org-e-odt-export-to-odt + (memq 'subtree optns) (memq 'visible optns) (memq 'body optns)))) + ;; Publishing facilities + (?F + (org-e-publish-current-file (memq 'force optns))) + (?P + (org-e-publish-current-project (memq 'force optns))) + (?X + (let ((project + (assoc (org-icompleting-read + "Publish project: " org-e-publish-project-alist nil t) + org-e-publish-project-alist))) + (org-e-publish project (memq 'force optns)))) + (?E + (org-e-publish-all (memq 'force optns))) + ;; Undefined command. + (t (error "No command associated with key %s" + (char-to-string raw-key)))))) + +(defun org-export-dispatch-ui (options expertp) + "Handle interface for `org-export-dispatch'. + +OPTIONS is a list containing current interactive options set for +export. It can contain any of the following symbols: +`body' toggles a body-only export +`subtree' restricts export to current subtree +`visible' restricts export to visible part of buffer. +`force' force publishing files. + +EXPERTP, when non-nil, triggers expert UI. In that case, no help +buffer is provided, but indications about currently active +options are given in the prompt. Moreover, \[?] allows to switch +back to standard interface. + +Return value is a list with key pressed as CAR and a list of +final interactive export options as CDR." + (let ((help + (format "---- (Options) ------------------------------------------- + +\[1] Body only: %s [2] Export scope: %s +\[3] Visible only: %s [4] Force publishing: %s + + +--- (ASCII/Latin-1/UTF-8 Export) ------------------------- + +\[a/n/u] to TXT file [A/N/U] to temporary buffer + +--- (HTML Export) ---------------------------------------- + +\[h] to HTML file [b] ... and open it +\[H] to temporary buffer + +--- (LaTeX Export) --------------------------------------- + +\[l] to TEX file [L] to temporary buffer +\[p] to PDF file [d] ... and open it + +--- (ODF Export) ----------------------------------------- + +\[o] to ODT file [O] ... and open it + +--- (Publish) -------------------------------------------- + +\[F] current file [P] current project +\[X] a project [E] every project" + (if (memq 'body options) "On " "Off") + (if (memq 'subtree options) "Subtree" "Buffer ") + (if (memq 'visible options) "On " "Off") + (if (memq 'force options) "On " "Off"))) + (standard-prompt "Export command: ") + (expert-prompt (format "Export command (%s%s%s%s): " + (if (memq 'body options) "b" "-") + (if (memq 'subtree options) "s" "-") + (if (memq 'visible options) "v" "-") + (if (memq 'force options) "f" "-"))) + (handle-keypress + (function + ;; Read a character from command input, toggling interactive + ;; options when applicable. PROMPT is the displayed prompt, + ;; as a string. + (lambda (prompt) + (let ((key (read-char-exclusive prompt))) + (cond + ;; Ignore non-standard characters (i.e. "M-a"). + ((not (characterp key)) (org-export-dispatch-ui options expertp)) + ;; Help key: Switch back to standard interface if + ;; expert UI was active. + ((eq key ??) (org-export-dispatch-ui options nil)) + ;; Toggle export options. + ((memq key '(?1 ?2 ?3 ?4)) + (org-export-dispatch-ui + (let ((option (case key (?1 'body) (?2 'subtree) (?3 'visible) + (?4 'force)))) + (if (memq option options) (remq option options) + (cons option options))) + expertp)) + ;; Action selected: Send key and options back to + ;; `org-export-dispatch'. + (t (cons key options)))))))) + ;; With expert UI, just read key with a fancy prompt. In standard + ;; UI, display an intrusive help buffer. + (if expertp (funcall handle-keypress expert-prompt) + (save-window-excursion + (delete-other-windows) + (with-output-to-temp-buffer "*Org Export/Publishing Help*" (princ help)) + (org-fit-window-to-buffer + (get-buffer-window "*Org Export/Publishing Help*")) + (funcall handle-keypress standard-prompt))))) + + +(provide 'org-export) +;;; org-export.el ends here diff --git a/contrib/lisp/org-git-link.el b/contrib/lisp/org-git-link.el new file mode 100644 index 0000000..8223712 --- /dev/null +++ b/contrib/lisp/org-git-link.el @@ -0,0 +1,220 @@ +;;; org-git-link.el --- Provide org links to specific file version + +;; Copyright (C) 2009-2012 Reimar Finken + +;; Author: Reimar Finken <reimar.finken@gmx.de> +;; Keywords: files, calendar, hypermedia + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distaributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; `org-git-link.el' defines two new link types. The `git' link +;; type is meant to be used in the typical scenario and mimics the +;; `file' link syntax as closely as possible. The `gitbare' link +;; type exists mostly for debugging reasons, but also allows e.g. +;; linking to files in a bare git repository for the experts. + +;; * User friendy form +;; [[git:/path/to/file::searchstring]] + +;; This form is the familiar from normal org file links +;; including search options. However, its use is +;; restricted to files in a working directory and does not +;; handle bare repositories on purpose (see the bare form for +;; that). + +;; The search string references a commit (a tree-ish in Git +;; terminology). The two most useful types of search strings are + +;; - A symbolic ref name, usually a branch or tag name (e.g. +;; master or nobelprize). +;; - A ref followed by the suffix @ with a date specification +;; enclosed in a brace pair (e.g. {yesterday}, {1 month 2 +;; weeks 3 days 1 hour 1 second ago} or {1979-02-26 18:30:00}) +;; to specify the value of the ref at a prior point in time +;; +;; * Bare git form +;; [[gitbare:$GIT_DIR::$OBJECT]] +;; +;; This is the more bare metal version, which gives the user most +;; control. It directly translates to the git command +;; git --no-pager --git-dir=$GIT_DIR show $OBJECT +;; Using this version one can also view files from a bare git +;; repository. For detailed information on how to specify an +;; object, see the man page of `git-rev-parse' (section +;; SPECIFYING REVISIONS). A specific blob (file) can be +;; specified by a suffix clolon (:) followed by a path. + +;;; Code: + +(require 'org) +(defcustom org-git-program "git" + "Name of the git executable used to follow git links." + :type '(string) + :group 'org) + +;; org link functions +;; bare git link +(org-add-link-type "gitbare" 'org-gitbare-open) + +(defun org-gitbare-open (str) + (let* ((strlist (org-git-split-string str)) + (gitdir (first strlist)) + (object (second strlist))) + (org-git-open-file-internal gitdir object))) + + +(defun org-git-open-file-internal (gitdir object) + (let* ((sha (org-git-blob-sha gitdir object)) + (tmpdir (concat temporary-file-directory "org-git-" sha)) + (filename (org-git-link-filename object)) + (tmpfile (expand-file-name filename tmpdir))) + (unless (file-readable-p tmpfile) + (make-directory tmpdir) + (with-temp-file tmpfile + (org-git-show gitdir object (current-buffer)))) + (org-open-file tmpfile) + (set-buffer (get-file-buffer tmpfile)) + (setq buffer-read-only t))) + +;; user friendly link +(org-add-link-type "git" 'org-git-open) + +(defun org-git-open (str) + (let* ((strlist (org-git-split-string str)) + (filepath (first strlist)) + (commit (second strlist)) + (dirlist (org-git-find-gitdir (file-truename filepath))) + (gitdir (first dirlist)) + (relpath (second dirlist))) + (org-git-open-file-internal gitdir (concat commit ":" relpath)))) + + +;; Utility functions (file names etc) + +(defun org-git-split-dirpath (dirpath) + "Given a directory name, return '(dirname basname)" + (let ((dirname (file-name-directory (directory-file-name dirpath))) + (basename (file-name-nondirectory (directory-file-name dirpath)))) + (list dirname basename))) + +;; finding the git directory +(defun org-git-find-gitdir (path) + "Given a file (not necessarily existing) file path, return the + a pair (gitdir relpath), where gitdir is the path to the first + .git subdirectory found updstream and relpath is the rest of + the path. Example: (org-git-find-gitdir + \"~/gitrepos/foo/bar.txt\") returns + '(\"/home/user/gitrepos/.git\" \"foo/bar.txt\"). When not in a git repository, return nil." + (let ((dir (file-name-directory path)) + (relpath (file-name-nondirectory path))) + (catch 'toplevel + (while (not (file-exists-p (expand-file-name ".git" dir))) + (let ((dirlist (org-git-split-dirpath dir))) + (when (string= (second dirlist) "") ; at top level + (throw 'toplevel nil)) + (setq dir (first dirlist) + relpath (concat (file-name-as-directory (second dirlist)) relpath)))) + (list (expand-file-name ".git" dir) relpath)))) + + +(if (featurep 'xemacs) + (defalias 'org-git-gitrepos-p 'org-git-find-gitdir) + (defalias 'org-git-gitrepos-p 'org-git-find-gitdir + "Return non-nil if path is in git repository")) + +;; splitting the link string + +;; Both link open functions are called with a string of +;; consisting of two parts separated by a double colon (::). +(defun org-git-split-string (str) + "Given a string of the form \"str1::str2\", return a list of + two substrings \'(\"str1\" \"str2\"). If the double colon is mising, take str2 to be the empty string." + (let ((strlist (split-string str "::"))) + (cond ((= 1 (length strlist)) + (list (car strlist) "")) + ((= 2 (length strlist)) + strlist) + (t (error "org-git-split-string: only one :: allowed: %s" str))))) + +;; finding the file name part of a commit +(defun org-git-link-filename (str) + "Given an object description (see the man page of + git-rev-parse), return the nondirectory part of the referenced + filename, if it can be extracted. Otherwise, return a valid + filename." + (let* ((match (and (string-match "[^:]+$" str) + (match-string 0 str))) + (filename (and match (file-name-nondirectory match)))) ;extract the final part without slash + filename)) + +;; creating a link +(defun org-git-create-searchstring (branch timestring) + (concat branch "@{" timestring "}")) + + +(defun org-git-create-git-link (file) + "Create git link part to file at specific time" + (interactive "FFile: ") + (let* ((gitdir (first (org-git-find-gitdir (file-truename file)))) + (branchname (org-git-get-current-branch gitdir)) + (timestring (format-time-string "%Y-%m-%d" (current-time)))) + (contact "git:" file "::" (org-git-create-searchstring branchname timestring)))) + +(defun org-git-store-link () + "Store git link to current file." + (when (buffer-file-name) + (let ((file (abbreviate-file-name (buffer-file-name)))) + (when (org-git-gitrepos-p file) + (org-store-link-props + :type "git" + :link (org-git-create-git-link file)))))) + +(add-hook 'org-store-link-functions 'org-git-store-link) + +(defun org-git-insert-link-interactively (file searchstring &optional description) + (interactive "FFile: \nsSearch string: \nsDescription: ") + (insert (org-make-link-string (concat "git:" file "::" searchstring) description))) + +;; Calling git +(defun org-git-show (gitdir object buffer) + "Show the output of git --git-dir=gitdir show object in buffer." + (unless + (zerop (call-process org-git-program nil buffer nil + "--no-pager" (concat "--git-dir=" gitdir) "show" object)) + (error "git error: %s " (save-excursion (set-buffer buffer) + (buffer-string))))) + +(defun org-git-blob-sha (gitdir object) + "Return sha of the referenced object" + (with-temp-buffer + (if (zerop (call-process org-git-program nil t nil + "--no-pager" (concat "--git-dir=" gitdir) "rev-parse" object)) + (buffer-substring (point-min) (1- (point-max))) ; to strip off final newline + (error "git error: %s " (buffer-string))))) + +(defun org-git-get-current-branch (gitdir) + "Return the name of the current branch." + (with-temp-buffer + (if (not (zerop (call-process org-git-program nil t nil + "--no-pager" (concat "--git-dir=" gitdir) "symbolic-ref" "-q" "HEAD"))) + (error "git error: %s " (buffer-string)) + (goto-char (point-min)) + (if (looking-at "^refs/heads/") ; 11 characters + (buffer-substring 12 (1- (point-max))))))) ; to strip off final newline + +(provide 'org-git-link) + +;;; org-git-link.el ends here diff --git a/contrib/lisp/org-interactive-query.el b/contrib/lisp/org-interactive-query.el new file mode 100644 index 0000000..ab6669b --- /dev/null +++ b/contrib/lisp/org-interactive-query.el @@ -0,0 +1,312 @@ +;;; org-interactive-query.el --- Interactive modification of agenda query +;; +;; Copyright 2007-2012 Free Software Foundation, Inc. +;; +;; Author: Christopher League <league at contrapunctus dot net> +;; Version: 1.0 +;; Keywords: org, wp +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; Commentary: +;; + +;; This library implements interactive modification of a tags/todo query +;; in the org-agenda. It adds 4 keys to the agenda +;; +;; / add a keyword as a positive selection criterion +;; \ add a keyword as a newgative selection criterion +;; = clear a keyword from the selection string +;; ; + +(require 'org) + +(org-defkey org-agenda-mode-map "=" 'org-agenda-query-clear-cmd) +(org-defkey org-agenda-mode-map "/" 'org-agenda-query-and-cmd) +(org-defkey org-agenda-mode-map ";" 'org-agenda-query-or-cmd) +(org-defkey org-agenda-mode-map "\\" 'org-agenda-query-not-cmd) + +;;; Agenda interactive query manipulation + +(defcustom org-agenda-query-selection-single-key t + "Non-nil means query manipulation exits after first change. +When nil, you have to press RET to exit it. +During query selection, you can toggle this flag with `C-c'. +This variable can also have the value `expert'. In this case, the window +displaying the tags menu is not even shown, until you press C-c again." + :group 'org-agenda + :type '(choice + (const :tag "No" nil) + (const :tag "Yes" t) + (const :tag "Expert" expert))) + +(defun org-agenda-query-selection (current op table &optional todo-table) + "Fast query manipulation with single keys. +CURRENT is the current query string, OP is the initial +operator (one of \"+|-=\"), TABLE is an alist of tags and +corresponding keys, possibly with grouping information. +TODO-TABLE is a similar table with TODO keywords, should these +have keys assigned to them. If the keys are nil, a-z are +automatically assigned. Returns the new query string, or nil to +not change the current one." + (let* ((fulltable (append table todo-table)) + (maxlen (apply 'max (mapcar + (lambda (x) + (if (stringp (car x)) (string-width (car x)) 0)) + fulltable))) + (fwidth (+ maxlen 3 1 3)) + (ncol (/ (- (window-width) 4) fwidth)) + (expert (eq org-agenda-query-selection-single-key 'expert)) + (exit-after-next org-agenda-query-selection-single-key) + (done-keywords org-done-keywords) + tbl char cnt e groups ingroup + tg c2 c c1 ntable rtn) + (save-window-excursion + (if expert + (set-buffer (get-buffer-create " *Org tags*")) + (delete-other-windows) + (split-window-vertically) + (org-switch-to-buffer-other-window (get-buffer-create " *Org tags*"))) + (erase-buffer) + (org-set-local 'org-done-keywords done-keywords) + (insert "Query: " current "\n") + (org-agenda-query-op-line op) + (insert "\n\n") + (org-fast-tag-show-exit exit-after-next) + (setq tbl fulltable char ?a cnt 0) + (while (setq e (pop tbl)) + (cond + ((equal e '(:startgroup)) + (push '() groups) (setq ingroup t) + (when (not (= cnt 0)) + (setq cnt 0) + (insert "\n")) + (insert "{ ")) + ((equal e '(:endgroup)) + (setq ingroup nil cnt 0) + (insert "}\n")) + (t + (setq tg (car e) c2 nil) + (if (cdr e) + (setq c (cdr e)) + ;; automatically assign a character. + (setq c1 (string-to-char + (downcase (substring + tg (if (= (string-to-char tg) ?@) 1 0))))) + (if (or (rassoc c1 ntable) (rassoc c1 table)) + (while (or (rassoc char ntable) (rassoc char table)) + (setq char (1+ char))) + (setq c2 c1)) + (setq c (or c2 char))) + (if ingroup (push tg (car groups))) + (setq tg (org-add-props tg nil 'face + (cond + ((not (assoc tg table)) + (org-get-todo-face tg)) + (t nil)))) + (if (and (= cnt 0) (not ingroup)) (insert " ")) + (insert "[" c "] " tg (make-string + (- fwidth 4 (length tg)) ?\ )) + (push (cons tg c) ntable) + (when (= (setq cnt (1+ cnt)) ncol) + (insert "\n") + (if ingroup (insert " ")) + (setq cnt 0))))) + (setq ntable (nreverse ntable)) + (insert "\n") + (goto-char (point-min)) + (if (and (not expert) (fboundp 'fit-window-to-buffer)) + (fit-window-to-buffer)) + (setq rtn + (catch 'exit + (while t + (message "[a-z..]:Toggle [SPC]:clear [RET]:accept [TAB]:free%s%s" + (if groups " [!] no groups" " [!]groups") + (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi"))) + (setq c (let ((inhibit-quit t)) (read-char-exclusive))) + (cond + ((= c ?\r) (throw 'exit t)) + ((= c ?!) + (setq groups (not groups)) + (goto-char (point-min)) + (while (re-search-forward "[{}]" nil t) (replace-match " "))) + ((= c ?\C-c) + (if (not expert) + (org-fast-tag-show-exit + (setq exit-after-next (not exit-after-next))) + (setq expert nil) + (delete-other-windows) + (split-window-vertically) + (org-switch-to-buffer-other-window " *Org tags*") + (and (fboundp 'fit-window-to-buffer) + (fit-window-to-buffer)))) + ((or (= c ?\C-g) + (and (= c ?q) (not (rassoc c ntable)))) + (setq quit-flag t)) + ((= c ?\ ) + (setq current "") + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\[) ; clear left + (org-agenda-query-decompose current) + (setq current (concat "/" (match-string 2 current))) + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\]) ; clear right + (org-agenda-query-decompose current) + (setq current (match-string 1 current)) + (if exit-after-next (setq exit-after-next 'now))) + ((= c ?\t) + (condition-case nil + (setq current (read-string "Query: " current)) + (quit)) + (if exit-after-next (setq exit-after-next 'now))) + ;; operators + ((or (= c ?/) (= c ?+)) (setq op "+")) + ((or (= c ?\;) (= c ?|)) (setq op "|")) + ((or (= c ?\\) (= c ?-)) (setq op "-")) + ((= c ?=) (setq op "=")) + ;; todos + ((setq e (rassoc c todo-table) tg (car e)) + (setq current (org-agenda-query-manip + current op groups 'todo tg)) + (if exit-after-next (setq exit-after-next 'now))) + ;; tags + ((setq e (rassoc c ntable) tg (car e)) + (setq current (org-agenda-query-manip + current op groups 'tag tg)) + (if exit-after-next (setq exit-after-next 'now)))) + (if (eq exit-after-next 'now) (throw 'exit t)) + (goto-char (point-min)) + (beginning-of-line 1) + (delete-region (point) (point-at-eol)) + (insert "Query: " current) + (beginning-of-line 2) + (delete-region (point) (point-at-eol)) + (org-agenda-query-op-line op) + (goto-char (point-min))))) + (if rtn current nil)))) + +(defun org-agenda-query-op-line (op) + (insert "Operator: " + (org-agenda-query-op-entry (equal op "+") "/+" "and") + (org-agenda-query-op-entry (equal op "|") ";|" "or") + (org-agenda-query-op-entry (equal op "-") "\\-" "not") + (org-agenda-query-op-entry (equal op "=") "=" "clear"))) + +(defun org-agenda-query-op-entry (matchp chars str) + (if matchp + (org-add-props (format "[%s %s] " chars (upcase str)) + nil 'face 'org-todo) + (format "[%s]%s " chars str))) + +(defun org-agenda-query-decompose (current) + (string-match "\\([^/]*\\)/?\\(.*\\)" current)) + +(defun org-agenda-query-clear (current prefix tag) + (if (string-match (concat prefix "\\b" (regexp-quote tag) "\\b") current) + (replace-match "" t t current) + current)) + +(defun org-agenda-query-manip (current op groups kind tag) + "Apply an operator to a query string and a tag. +CURRENT is the current query string, OP is the operator, GROUPS is a +list of lists of tags that are mutually exclusive. KIND is 'tag for a +regular tag, or 'todo for a TODO keyword, and TAG is the tag or +keyword string." + ;; If this tag is already in query string, remove it. + (setq current (org-agenda-query-clear current "[-\\+&|]?" tag)) + (if (equal op "=") current + ;; When using AND, also remove mutually exclusive tags. + (if (equal op "+") + (loop for g in groups do + (if (member tag g) + (mapc (lambda (x) + (setq current + (org-agenda-query-clear current "\\+" x))) + g)))) + ;; Decompose current query into q1 (tags) and q2 (TODOs). + (org-agenda-query-decompose current) + (let* ((q1 (match-string 1 current)) + (q2 (match-string 2 current))) + (cond + ((eq kind 'tag) + (concat q1 op tag "/" q2)) + ;; It's a TODO; when using AND, drop all other TODOs. + ((equal op "+") + (concat q1 "/+" tag)) + (t + (concat q1 "/" q2 op tag)))))) + +(defun org-agenda-query-global-todo-keys (&optional files) + "Return alist of all TODO keywords and their fast keys, in all FILES." + (let (alist) + (unless (and files (car files)) + (setq files (org-agenda-files))) + (save-excursion + (loop for f in files do + (set-buffer (find-file-noselect f)) + (loop for k in org-todo-key-alist do + (setq alist (org-agenda-query-merge-todo-key + alist k))))) + alist)) + +(defun org-agenda-query-merge-todo-key (alist entry) + (let (e) + (cond + ;; if this is not a keyword (:startgroup, etc), ignore it + ((not (stringp (car entry)))) + ;; if keyword already exists, replace char if it's null + ((setq e (assoc (car entry) alist)) + (when (null (cdr e)) (setcdr e (cdr entry)))) + ;; if char already exists, prepend keyword but drop char + ((rassoc (cdr entry) alist) + (message "TRACE POSITION 2") + (setq alist (cons (cons (car entry) nil) alist))) + ;; else, prepend COPY of entry + (t + (setq alist (cons (cons (car entry) (cdr entry)) alist))))) + alist) + +(defun org-agenda-query-generic-cmd (op) + "Activate query manipulation with OP as initial operator." + (let ((q (org-agenda-query-selection org-agenda-query-string op + org-tag-alist + (org-agenda-query-global-todo-keys)))) + (when q + (setq org-agenda-query-string q) + (org-agenda-redo)))) + +(defun org-agenda-query-clear-cmd () + "Activate query manipulation, to clear a tag from the string." + (interactive) + (org-agenda-query-generic-cmd "=")) + +(defun org-agenda-query-and-cmd () + "Activate query manipulation, initially using the AND (+) operator." + (interactive) + (org-agenda-query-generic-cmd "+")) + +(defun org-agenda-query-or-cmd () + "Activate query manipulation, initially using the OR (|) operator." + (interactive) + (org-agenda-query-generic-cmd "|")) + +(defun org-agenda-query-not-cmd () + "Activate query manipulation, initially using the NOT (-) operator." + (interactive) + (org-agenda-query-generic-cmd "-")) + +(provide 'org-interactive-query) diff --git a/contrib/lisp/org-invoice.el b/contrib/lisp/org-invoice.el new file mode 100644 index 0000000..c951d4e --- /dev/null +++ b/contrib/lisp/org-invoice.el @@ -0,0 +1,401 @@ +;;; org-invoice.el --- Help manage client invoices in OrgMode +;; +;; Copyright (C) 2008-2012 pmade inc. (Peter Jones pjones@pmade.com) +;; +;; This file is not part of GNU Emacs. +;; +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;; +;; Commentary: +;; +;; Building on top of the terrific OrgMode, org-invoice tries to +;; provide functionality for managing invoices. Currently, it does +;; this by implementing an OrgMode dynamic block where invoice +;; information is aggregated so that it can be exported. +;; +;; It also provides a library of functions that can be used to collect +;; this invoice information and use it in other ways, such as +;; submitting it to on-line invoicing tools. +;; +;; I'm already working on an elisp package to submit this invoice data +;; to the FreshBooks on-line accounting tool. +;; +;; Usage: +;; +;; In your ~/.emacs: +;; (autoload 'org-invoice-report "org-invoice") +;; (autoload 'org-dblock-write:invoice "org-invoice") +;; +;; See the documentation in the following functions: +;; +;; `org-invoice-report' +;; `org-dblock-write:invoice' +;; +;; Latest version: +;; +;; git clone git://pmade.com/elisp +(eval-when-compile + (require 'cl) + (require 'org)) + +(defgroup org-invoice nil + "OrgMode Invoice Helper" + :tag "Org-Invoice" :group 'org) + +(defcustom org-invoice-long-date-format "%A, %B %d, %Y" + "The format string for long dates." + :type 'string :group 'org-invoice) + +(defcustom org-invoice-strip-ts t + "Remove org timestamps that appear in headings." + :type 'boolean :group 'org-invoice) + +(defcustom org-invoice-default-level 2 + "The heading level at which a new invoice starts. This value +is used if you don't specify a scope option to the invoice block, +and when other invoice helpers are trying to find the heading +that starts an invoice. + +The default is 2, assuming that you structure your invoices so +that they fall under a single heading like below: + +* Invoices +** This is invoice number 1... +** This is invoice number 2... + +If you don't structure your invoices using those conventions, +change this setting to the number that corresponds to the heading +at which an invoice begins." + :type 'integer :group 'org-invoice) + +(defcustom org-invoice-start-hook nil + "Hook called when org-invoice is about to collect data from an +invoice heading. When this hook is called, point will be on the +heading where the invoice begins. + +When called, `org-invoice-current-invoice' will be set to the +alist that represents the info for this invoice." + :type 'hook :group 'org-invoice) + + (defcustom org-invoice-heading-hook nil + "Hook called when org-invoice is collecting data from a +heading. You can use this hook to add additional information to +the alist that represents the heading. + +When this hook is called, point will be on the current heading +being processed, and `org-invoice-current-item' will contain the +alist for the current heading. + +This hook is called repeatedly for each invoice item processed." + :type 'hook :group 'org-invoice) + +(defvar org-invoice-current-invoice nil + "Information about the current invoice.") + +(defvar org-invoice-current-item nil + "Information about the current invoice item.") + +(defvar org-invoice-table-params nil + "The table parameters currently being used.") + +(defvar org-invoice-total-time nil + "The total invoice time for the summary line.") + +(defvar org-invoice-total-price nil + "The total invoice price for the summary line.") + +(defconst org-invoice-version "1.0.0" + "The org-invoice version number.") + +(defun org-invoice-goto-tree (&optional tree) + "Move point to the heading that represents the head of the +current invoice. The heading level will be taken from +`org-invoice-default-level' unless tree is set to a string that +looks like tree2, where the level is 2." + (let ((level org-invoice-default-level)) + (save-match-data + (when (and tree (string-match "^tree\\([0-9]+\\)$" tree)) + (setq level (string-to-number (match-string 1 tree))))) + (org-back-to-heading) + (while (and (> (org-reduced-level (org-outline-level)) level) + (org-up-heading-safe))))) + +(defun org-invoice-heading-info () + "Return invoice information from the current heading." + (let ((title (org-no-properties (org-get-heading t))) + (date (org-entry-get nil "TIMESTAMP" 'selective)) + (work (org-entry-get nil "WORK" nil)) + (rate (or (org-entry-get nil "RATE" t) "0")) + (level (org-outline-level)) + raw-date long-date) + (unless date (setq date (org-entry-get nil "TIMESTAMP_IA" 'selective))) + (unless date (setq date (org-entry-get nil "TIMESTAMP" t))) + (unless date (setq date (org-entry-get nil "TIMESTAMP_IA" t))) + (unless work (setq work (org-entry-get nil "CLOCKSUM" nil))) + (unless work (setq work "00:00")) + (when date + (setq raw-date (apply 'encode-time (org-parse-time-string date))) + (setq long-date (format-time-string org-invoice-long-date-format raw-date))) + (when (and org-invoice-strip-ts (string-match org-ts-regexp-both title)) + (setq title (replace-match "" nil nil title))) + (when (string-match "^[ \t]+" title) + (setq title (replace-match "" nil nil title))) + (when (string-match "[ \t]+$" title) + (setq title (replace-match "" nil nil title))) + (setq work (org-hh:mm-string-to-minutes work)) + (setq rate (string-to-number rate)) + (setq org-invoice-current-item (list (cons 'title title) + (cons 'date date) + (cons 'raw-date raw-date) + (cons 'long-date long-date) + (cons 'work work) + (cons 'rate rate) + (cons 'level level) + (cons 'price (* rate (/ work 60.0))))) + (run-hook-with-args 'org-invoice-heading-hook) + org-invoice-current-item)) + +(defun org-invoice-level-min-max (ls) + "Return a list where the car is the min level, and the cdr the max." + (let ((max 0) min level) + (dolist (info ls) + (when (cdr (assoc 'date info)) + (setq level (cdr (assoc 'level info))) + (when (or (not min) (< level min)) (setq min level)) + (when (> level max) (setq max level)))) + (cons (or min 0) max))) + +(defun org-invoice-collapse-list (ls) + "Reorganize the given list by dates." + (let ((min-max (org-invoice-level-min-max ls)) new) + (dolist (info ls) + (let* ((date (cdr (assoc 'date info))) + (work (cdr (assoc 'work info))) + (price (cdr (assoc 'price info))) + (long-date (cdr (assoc 'long-date info))) + (level (cdr (assoc 'level info))) + (bucket (cdr (assoc date new)))) + (if (and (/= (car min-max) (cdr min-max)) + (= (car min-max) level) + (= work 0) (not bucket) date) + (progn + (setq info (assq-delete-all 'work info)) + (push (cons 'total-work 0) info) + (push (cons date (list info)) new) + (setq bucket (cdr (assoc date new)))) + (when (and date (not bucket)) + (setq bucket (list (list (cons 'date date) + (cons 'title long-date) + (cons 'total-work 0) + (cons 'price 0)))) + (push (cons date bucket) new) + (setq bucket (cdr (assoc date new)))) + (when (and date bucket) + (setcdr (assoc 'total-work (car bucket)) + (+ work (cdr (assoc 'total-work (car bucket))))) + (setcdr (assoc 'price (car bucket)) + (+ price (cdr (assoc 'price (car bucket))))) + (nconc bucket (list info)))))) + (nreverse new))) + +(defun org-invoice-info-to-table (info) + "Create a single org table row from the given info alist." + (let ((title (cdr (assoc 'title info))) + (total (cdr (assoc 'total-work info))) + (work (cdr (assoc 'work info))) + (price (cdr (assoc 'price info))) + (with-price (plist-get org-invoice-table-params :price))) + (unless total + (setq + org-invoice-total-time (+ org-invoice-total-time work) + org-invoice-total-price (+ org-invoice-total-price price))) + (setq total (and total (org-minutes-to-hh:mm-string total))) + (setq work (and work (org-minutes-to-hh:mm-string work))) + (insert-before-markers + (concat "|" title + (cond + (total (concat "|" total)) + (work (concat "|" work))) + (and with-price price (concat "|" (format "%.2f" price))) + "|" "\n")))) + +(defun org-invoice-list-to-table (ls) + "Convert a list of heading info to an org table" + (let ((with-price (plist-get org-invoice-table-params :price)) + (with-summary (plist-get org-invoice-table-params :summary)) + (with-header (plist-get org-invoice-table-params :headers)) + (org-invoice-total-time 0) + (org-invoice-total-price 0)) + (insert-before-markers + (concat "| Task / Date | Time" (and with-price "| Price") "|\n")) + (dolist (info ls) + (insert-before-markers "|-\n") + (mapc 'org-invoice-info-to-table (if with-header (cdr info) (cdr (cdr info))))) + (when with-summary + (insert-before-markers + (concat "|-\n|Total:|" + (org-minutes-to-hh:mm-string org-invoice-total-time) + (and with-price (concat "|" (format "%.2f" org-invoice-total-price))) + "|\n"))))) + +(defun org-invoice-collect-invoice-data () + "Collect all the invoice data from the current OrgMode tree and +return it. Before you call this function, move point to the +heading that begins the invoice data, usually using the +`org-invoice-goto-tree' function." + (let ((org-invoice-current-invoice + (list (cons 'point (point)) (cons 'buffer (current-buffer)))) + (org-invoice-current-item nil)) + (save-restriction + (org-narrow-to-subtree) + (org-clock-sum) + (run-hook-with-args 'org-invoice-start-hook) + (cons org-invoice-current-invoice + (org-invoice-collapse-list + (org-map-entries 'org-invoice-heading-info t 'tree 'archive)))))) + +(defun org-dblock-write:invoice (params) + "Function called by OrgMode to write the invoice dblock. To +create an invoice dblock you can use the `org-invoice-report' +function. + +The following parameters can be given to the invoice block (for +information about dblock parameters, please see the Org manual): + +:scope Allows you to override the `org-invoice-default-level' + variable. The only supported values right now are ones + that look like :tree1, :tree2, etc. + +:prices Set to nil to turn off the price column. + +:headers Set to nil to turn off the group headers. + +:summary Set to nil to turn off the final summary line." + (let ((scope (plist-get params :scope)) + (org-invoice-table-params params) + (zone (move-marker (make-marker) (point))) + table) + (unless scope (setq scope 'default)) + (unless (plist-member params :price) (plist-put params :price t)) + (unless (plist-member params :summary) (plist-put params :summary t)) + (unless (plist-member params :headers) (plist-put params :headers t)) + (save-excursion + (cond + ((eq scope 'tree) (org-invoice-goto-tree "tree1")) + ((eq scope 'default) (org-invoice-goto-tree)) + ((symbolp scope) (org-invoice-goto-tree (symbol-name scope)))) + (setq table (org-invoice-collect-invoice-data)) + (goto-char zone) + (org-invoice-list-to-table (cdr table)) + (goto-char zone) + (org-table-align) + (move-marker zone nil)))) + +(defun org-invoice-in-report-p () + "Check to see if point is inside an invoice report." + (let ((pos (point)) start) + (save-excursion + (end-of-line 1) + (and (re-search-backward "^#\\+BEGIN:[ \t]+invoice" nil t) + (setq start (match-beginning 0)) + (re-search-forward "^#\\+END:.*" nil t) + (>= (match-end 0) pos) + start)))) + +(defun org-invoice-report (&optional jump) + "Create or update an invoice dblock report. If point is inside +an existing invoice report, the report is updated. If point +isn't inside an invoice report, a new report is created. + +When called with a prefix argument, move to the first invoice +report after point and update it. + +For information about various settings for the invoice report, +see the `org-dblock-write:invoice' function documentation. + +An invoice report is created by reading a heading tree and +collecting information from various properties. It is assumed +that all invoices start at a second level heading, but this can +be configured using the `org-invoice-default-level' variable. + +Here is an example, where all invoices fall under the first-level +heading Invoices: + +* Invoices +** Client Foo (Jan 01 - Jan 15) +*** [2008-01-01 Tue] Built New Server for Production +*** [2008-01-02 Wed] Meeting with Team to Design New System +** Client Bar (Jan 01 - Jan 15) +*** [2008-01-01 Tue] Searched for Widgets on Google +*** [2008-01-02 Wed] Billed You for Taking a Nap + +In this layout, invoices begin at level two, and invoice +items (tasks) are at level three. You'll notice that each level +three heading starts with an inactive timestamp. The timestamp +can actually go anywhere you want, either in the heading, or in +the text under the heading. But you must have a timestamp +somewhere so that the invoice report can group your items by +date. + +Properties are used to collect various bits of information for +the invoice. All properties can be set on the invoice item +headings, or anywhere in the tree. The invoice report will scan +up the tree looking for each of the properties. + +Properties used: + +CLOCKSUM: You can use the Org clock-in and clock-out commands to + create a CLOCKSUM property. Also see WORK. + +WORK: An alternative to the CLOCKSUM property. This property + should contain the amount of work that went into this + invoice item formatted as HH:MM (e.g. 01:30). + +RATE: Used to calculate the total price for an invoice item. + Should be the price per hour that you charge (e.g. 45.00). + It might make more sense to place this property higher in + the hierarchy than on the invoice item headings. + +Using this information, a report is generated that details the +items grouped by days. For each day you will be able to see the +total number of hours worked, the total price, and the items +worked on. + +You can place the invoice report anywhere in the tree you want. +I place mine under a third-level heading like so: + +* Invoices +** An Invoice Header +*** [2008-11-25 Tue] An Invoice Item +*** Invoice Report +#+BEGIN: invoice +#+END:" + (interactive "P") + (let ((report (org-invoice-in-report-p))) + (when (and (not report) jump) + (when (re-search-forward "^#\\+BEGIN:[ \t]+invoice" nil t) + (org-show-entry) + (beginning-of-line) + (setq report (point)))) + (if report (goto-char report) + (org-create-dblock (list :name "invoice"))) + (org-update-dblock))) + +(provide 'org-invoice) diff --git a/contrib/lisp/org-jira.el b/contrib/lisp/org-jira.el new file mode 100644 index 0000000..2037029 --- /dev/null +++ b/contrib/lisp/org-jira.el @@ -0,0 +1,65 @@ +;;; org-jira.el --- add a jira:ticket protocol to Org +(defconst org-jira-version "0.1") +;; Copyright (C) 2008-2012 Jonathan Arkell. +;; Author: Jonathan Arkell <jonnay@jonnay.net> + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation version 2. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; For a copy of the GNU General Public License, search the Internet, +;; or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA + +;;; Commentary: +;; This adds a jira protocol to org mode. + +;;; Commands: +;; +;; Below are complete command list: +;; +;; +;;; Customizable Options: +;; +;; Below are customizable option list: +;; + +;; I had initially planned on adding bi-directional linking, so you +;; could store links from a jira ticket. I also wanted to import +;; tickets assigned to you as a task. However, I am no longer working +;; with JIRA, so this is now abandonware. + +;;; Installation: +;; Put org-jira.el somewhere in your load-path. +;; (Use M-x show-variable RET load-path to see what your load path is.) +;; Add this to your emacs init file, preferably after you load org mode. +;(require 'org-jira) + +;;; TODO: +;; - bi-directional links +;; - deeper importing, like tasks...? + +;;; CHANGELOG: +;; v 0.2 - ran through checkdoc +;; - Abandoned. +;; v 0.1 - Initial release + +(require 'jira) + +(org-add-link-type "jira" 'org-jira-open) + +(defun org-jira-open (path) + "Open a Jira Link from PATH." + (jira-show-issue path)) + + +(provide 'org-jira) + +;;; org-jira.el ends here diff --git a/contrib/lisp/org-learn.el b/contrib/lisp/org-learn.el new file mode 100644 index 0000000..0d5752b --- /dev/null +++ b/contrib/lisp/org-learn.el @@ -0,0 +1,177 @@ +;;; org-learn.el --- Implements SuperMemo's incremental learning algorithm + +;; Copyright (C) 2009-2012 Free Software Foundation, Inc. + +;; Author: John Wiegley <johnw at gnu dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 6.32trans +;; +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; The file implements the learning algorithm described at +;; http://supermemo.com/english/ol/sm5.htm, which is a system for reading +;; material according to "spaced repetition". See +;; http://en.wikipedia.org/wiki/Spaced_repetition for more details. +;; +;; To use, turn on state logging and schedule some piece of information you +;; want to read. Then in the agenda buffer type + +(require 'org) +(eval-when-compile + (require 'cl)) + +(defgroup org-learn nil + "Options concerning the learning code in Org-mode." + :tag "Org Learn" + :group 'org-progress) + +(defcustom org-learn-always-reschedule nil + "If non-nil, always reschedule items, even if retention was \"perfect\"." + :type 'boolean + :group 'org-learn) + +(defcustom org-learn-fraction 0.5 + "Controls the rate at which EF is increased or decreased. +Must be a number between 0 and 1 (the greater it is the faster +the changes of the OF matrix)." + :type 'float + :group 'org-learn) + +(defun initial-optimal-factor (n ef) + (if (= 1 n) + 4 + ef)) + +(defun get-optimal-factor (n ef of-matrix) + (let ((factors (assoc n of-matrix))) + (or (and factors + (let ((ef-of (assoc ef (cdr factors)))) + (and ef-of (cdr ef-of)))) + (initial-optimal-factor n ef)))) + +(defun set-optimal-factor (n ef of-matrix of) + (let ((factors (assoc n of-matrix))) + (if factors + (let ((ef-of (assoc ef (cdr factors)))) + (if ef-of + (setcdr ef-of of) + (push (cons ef of) (cdr factors)))) + (push (cons n (list (cons ef of))) of-matrix))) + of-matrix) + +(defun inter-repetition-interval (n ef &optional of-matrix) + (let ((of (get-optimal-factor n ef of-matrix))) + (if (= 1 n) + of + (* of (inter-repetition-interval (1- n) ef of-matrix))))) + +(defun modify-e-factor (ef quality) + (if (< ef 1.3) + 1.3 + (+ ef (- 0.1 (* (- 5 quality) (+ 0.08 (* (- 5 quality) 0.02))))))) + +(defun modify-of (of q fraction) + (let ((temp (* of (+ 0.72 (* q 0.07))))) + (+ (* (- 1 fraction) of) (* fraction temp)))) + +(defun calculate-new-optimal-factor (interval-used quality used-of + old-of fraction) + "This implements the SM-5 learning algorithm in Lisp. +INTERVAL-USED is the last interval used for the item in question. +QUALITY is the quality of the repetition response. +USED-OF is the optimal factor used in calculation of the last +interval used for the item in question. +OLD-OF is the previous value of the OF entry corresponding to the +relevant repetition number and the E-Factor of the item. +FRACTION is a number belonging to the range (0,1) determining the +rate of modifications (the greater it is the faster the changes +of the OF matrix). + +Returns the newly calculated value of the considered entry of the +OF matrix." + (let (;; the value proposed for the modifier in case of q=5 + (mod5 (/ (1+ interval-used) interval-used)) + ;; the value proposed for the modifier in case of q=2 + (mod2 (/ (1- interval-used) interval-used)) + ;; the number determining how many times the OF value will + ;; increase or decrease + modifier) + (if (< mod5 1.05) + (setq mod5 1.05)) + (if (< mod2 0.75) + (setq mod5 0.75)) + (if (> quality 4) + (setq modifier (1+ (* (- mod5 1) (- quality 4)))) + (setq modifier (- 1 (* (/ (- 1 mod2) 2) (- 4 quality))))) + (if (< modifier 0.05) + (setq modifier 0.05)) + (setq new-of (* used-of modifier)) + (if (> quality 4) + (if (< new-of old-of) + (setq new-of old-of))) + (if (< quality 4) + (if (> new-of old-of) + (setq new-of old-of))) + (setq new-of (+ (* new-of fraction) (* old-of (- 1 fraction)))) + (if (< new-of 1.2) + (setq new-of 1.2) + new-of))) + +(defvar initial-repetition-state '(-1 1 2.5 nil)) + +(defun determine-next-interval (n ef quality of-matrix) + (assert (> n 0)) + (assert (and (>= quality 0) (<= quality 5))) + (if (< quality 3) + (list (inter-repetition-interval n ef) (1+ n) ef nil) + (let ((next-ef (modify-e-factor ef quality))) + (setq of-matrix + (set-optimal-factor n next-ef of-matrix + (modify-of (get-optimal-factor n ef of-matrix) + quality org-learn-fraction)) + ef next-ef) + ;; For a zero-based quality of 4 or 5, don't repeat + (if (and (>= quality 4) + (not org-learn-always-reschedule)) + (list 0 (1+ n) ef of-matrix) + (list (inter-repetition-interval n ef of-matrix) (1+ n) + ef of-matrix))))) + +(defun org-smart-reschedule (quality) + (interactive "nHow well did you remember the information (on a scale of 0-5)? ") + (let* ((learn-str (org-entry-get (point) "LEARN_DATA")) + (learn-data (or (and learn-str + (read learn-str)) + (copy-list initial-repetition-state))) + closed-dates) + (setq learn-data + (determine-next-interval (nth 1 learn-data) + (nth 2 learn-data) + quality + (nth 3 learn-data))) + (org-entry-put (point) "LEARN_DATA" (prin1-to-string learn-data)) + (if (= 0 (nth 0 learn-data)) + (org-schedule t) + (org-schedule nil (time-add (current-time) + (days-to-time (nth 0 learn-data))))))) + +(provide 'org-learn) + +;;; org-learn.el ends here diff --git a/contrib/lisp/org-mac-iCal.el b/contrib/lisp/org-mac-iCal.el new file mode 100644 index 0000000..0fdc95f --- /dev/null +++ b/contrib/lisp/org-mac-iCal.el @@ -0,0 +1,251 @@ +;;; org-mac-iCal.el --- Imports events from iCal.app to the Emacs diary + +;; Copyright (C) 2009-2012 Christopher Suckling + +;; Author: Christopher Suckling <suckling at gmail dot com> + +;; This file is Free Software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; It is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;; Version: 0.1057.104 +;; Keywords: outlines, calendar + +;;; Commentary: +;; +;; This file provides the import of events from Mac OS X 10.5 iCal.app +;; into the Emacs diary (it is not compatible with OS X < 10.5). The +;; function org-mac-iCal will import events in all checked iCal.app +;; calendars for the date range org-mac-iCal-range months, centered +;; around the current date. +;; +;; CAVEAT: This function is destructive; it will overwrite the current +;; contents of the Emacs diary. +;; +;; Installation: add (require 'org-mac-iCal) to your .emacs. +;; +;; If you view Emacs diary entries in org-agenda, the following hook +;; will ensure that all-day events are not orphaned below TODO items +;; and that any supplementary fields to events (e.g. Location) are +;; grouped with their parent event +;; +;; (add-hook 'org-agenda-cleanup-fancy-diary-hook +;; (lambda () +;; (goto-char (point-min)) +;; (save-excursion +;; (while (re-search-forward "^[a-z]" nil t) +;; (goto-char (match-beginning 0)) +;; (insert "0:00-24:00 "))) +;; (while (re-search-forward "^ [a-z]" nil t) +;; (goto-char (match-beginning 0)) +;; (save-excursion +;; (re-search-backward "^[0-9]+:[0-9]+-[0-9]+:[0-9]+ " nil t)) +;; (insert (match-string 0))))) + +;;; Code: + +(defcustom org-mac-iCal-range 2 + "The range in months to import iCal.app entries into the Emacs +diary. The import is centered around today's date; thus a value +of 2 imports entries for one month before and one month after +today's date" + :group 'org-time + :type 'integer) + +(defun org-mac-iCal () + "Selects checked calendars in iCal.app and imports them into +the the Emacs diary" + (interactive) + + ;; kill diary buffers then empty diary files to avoid duplicates + (setq currentBuffer (buffer-name)) + (setq openBuffers (mapcar (function buffer-name) (buffer-list))) + (omi-kill-diary-buffer openBuffers) + (with-temp-buffer + (insert-file-contents diary-file) + (delete-region (point-min) (point-max)) + (write-region (point-min) (point-max) diary-file)) + + ;; determine available calendars + (setq caldav-folders (directory-files "~/Library/Calendars" 1 ".*caldav$")) + (setq caldav-calendars nil) + (mapc + (lambda (x) + (setq caldav-calendars (nconc caldav-calendars (directory-files x 1 ".*calendar$")))) + caldav-folders) + + (setq local-calendars nil) + (setq local-calendars (directory-files "~/Library/Calendars" 1 ".*calendar$")) + + (setq all-calendars (append caldav-calendars local-calendars)) + + ;; parse each calendar's Info.plist to see if calendar is checked in iCal + (setq all-calendars (delq 'nil (mapcar + (lambda (x) + (omi-checked x)) + all-calendars))) + + ;; for each calendar, concatenate individual events into a single ics file + (with-temp-buffer + (shell-command "sw_vers" (current-buffer)) + (when (re-search-backward "10\\.[567]" nil t) + (omi-concat-leopard-ics all-calendars))) + + ;; move all caldav ics files to the same place as local ics files + (mapc + (lambda (x) + (mapc + (lambda (y) + (rename-file (concat x "/" y); + (concat "~/Library/Calendars/" y))) + (directory-files x nil ".*ics$"))) + caldav-folders) + + ;; check calendar has contents and import + (setq import-calendars (directory-files "~/Library/Calendars" 1 ".*ics$")) + (mapc + (lambda (x) + (when (/= (nth 7 (file-attributes x 'string)) 0) + (omi-import-ics x))) + import-calendars) + + ;; tidy up intermediate files and buffers + (setq usedCalendarsBuffers (mapcar (function buffer-name) (buffer-list))) + (omi-kill-ics-buffer usedCalendarsBuffers) + (setq usedCalendarsFiles (directory-files "~/Library/Calendars" 1 ".*ics$")) + (omi-delete-ics-file usedCalendarsFiles) + + (org-pop-to-buffer-same-window currentBuffer)) + +(defun omi-concat-leopard-ics (list) + "Leopard stores each iCal.app event in a separate ics file. +Whilst useful for Spotlight indexing, this is less helpful for +icalendar-import-file. omi-concat-leopard-ics concatenates these +individual event files into a single ics file" + (mapc + (lambda (x) + (setq omi-leopard-events (directory-files (concat x "/Events") 1 ".*ics$")) + (with-temp-buffer + (mapc + (lambda (y) + (insert-file-contents (expand-file-name y))) + omi-leopard-events) + (write-region (point-min) (point-max) (concat (expand-file-name x) ".ics")))) + list)) + +(defun omi-import-ics (string) + "Imports an ics file into the Emacs diary. First tidies up the +ics file so that it is suitable for import and selects a sensible +date range so that Emacs calendar view doesn't grind to a halt" + (with-temp-buffer + (insert-file-contents string) + (goto-char (point-min)) + (while + (re-search-forward "^BEGIN:VCALENDAR$" nil t) + (setq startEntry (match-beginning 0)) + (re-search-forward "^END:VCALENDAR$" nil t) + (setq endEntry (match-end 0)) + (save-restriction + (narrow-to-region startEntry endEntry) + (goto-char (point-min)) + (re-search-forward "\\(^DTSTART;.*:\\)\\([0-9][0-9][0-9][0-9]\\)\\([0-9][0-9]\\)" nil t) + (if (or (eq (match-string 2) nil) (eq (match-string 3) nil)) + (progn + (setq yearEntry 1) + (setq monthEntry 1)) + (setq yearEntry (string-to-number (match-string 2))) + (setq monthEntry (string-to-number (match-string 3)))) + (setq year (string-to-number (format-time-string "%Y"))) + (setq month (string-to-number (format-time-string "%m"))) + (setq now (list month 1 year)) + (setq entryDate (list monthEntry 1 yearEntry)) + ;; Check to see if this is a repeating event + (goto-char (point-min)) + (setq isRepeating (re-search-forward "^RRULE:" nil t)) + ;; Delete if outside range and not repeating + (when (and + (not isRepeating) + (> (abs (- (calendar-absolute-from-gregorian now) + (calendar-absolute-from-gregorian entryDate))) + (* (/ org-mac-iCal-range 2) 30)) + (delete-region startEntry endEntry))) + (goto-char (point-max)))) + (while + (re-search-forward "^END:VEVENT$" nil t) + (delete-blank-lines)) + (goto-line 1) + (insert "BEGIN:VCALENDAR\n\n") + (goto-line 2) + (while + (re-search-forward "^BEGIN:VCALENDAR$" nil t) + (replace-match "\n")) + (goto-line 2) + (while + (re-search-forward "^END:VCALENDAR$" nil t) + (replace-match "\n")) + (insert "END:VCALENDAR") + (goto-line 1) + (delete-blank-lines) + (while + (re-search-forward "^END:VEVENT$" nil t) + (delete-blank-lines)) + (goto-line 1) + (while + (re-search-forward "^ORG.*" nil t) + (replace-match "\n")) + (goto-line 1) + (write-region (point-min) (point-max) string)) + + (icalendar-import-file string diary-file)) + +(defun omi-kill-diary-buffer (list) + (mapc + (lambda (x) + (if (string-match "^diary" x) + (kill-buffer x))) + list)) + +(defun omi-kill-ics-buffer (list) + (mapc + (lambda (x) + (if (string-match "ics$" x) + (kill-buffer x))) + list)) + +(defun omi-delete-ics-file (list) + (mapc + (lambda (x) + (delete-file x)) + list)) + +(defun omi-checked (directory) + "Parse Info.plist in iCal.app calendar folder and determine +whether Checked key is 1. If Checked key is not 1, remove +calendar from list of calendars for import" + (let* ((root (xml-parse-file (car (directory-files directory 1 "Info.plist")))) + (plist (car root)) + (dict (car (xml-get-children plist 'dict))) + (keys (cdr (xml-node-children dict))) + (keys (mapcar + (lambda (x) + (cond ((listp x) + x))) + keys)) + (keys (delq 'nil keys))) + (when (equal "1" (car (cddr (lax-plist-get keys '(key nil "Checked"))))) + directory))) + +(provide 'org-mac-iCal) + +;;; org-mac-iCal.el ends here diff --git a/contrib/lisp/org-mac-link-grabber.el b/contrib/lisp/org-mac-link-grabber.el new file mode 100644 index 0000000..b422bfb --- /dev/null +++ b/contrib/lisp/org-mac-link-grabber.el @@ -0,0 +1,467 @@ +;;; org-mac-link-grabber.el --- Grab links and url from various mac +;;; application and insert them as links into org-mode documents +;; +;; Copyright (c) 2010-2012 Free Software Foundation, Inc. +;; +;; Author: Anthony Lander <anthony.lander@gmail.com> +;; Version: 1.0.1 +;; Keywords: org, mac, hyperlink +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +;; +;;; Commentary: +;; +;; This code allows you to grab either the current selected items, or +;; the frontmost url in various mac appliations, and insert them as +;; hyperlinks into the current org-mode document at point. +;; +;; This code is heavily based on, and indeed requires, +;; org-mac-message.el written by John Weigley and Christopher +;; Suckling. +;; +;; Detailed comments for each application interface are inlined with +;; the code. Here is a brief overview of how the code interacts with +;; each application: +;; +;; Finder.app - grab links to the selected files in the frontmost window +;; Mail.app - grab links to the selected messages in the message list +;; AddressBook.app - Grab links to the selected addressbook Cards +;; Firefox.app - Grab the url of the frontmost tab in the frontmost window +;; Vimperator/Firefox.app - Grab the url of the frontmost tab in the frontmost window +;; Safari.app - Grab the url of the frontmost tab in the frontmost window +;; Google Chrome.app - Grab the url of the frontmost tab in the frontmost window +;; Together.app - Grab links to the selected items in the library list +;; +;; +;; Installation: +;; +;; add (require 'org-mac-link-grabber) to your .emacs, and optionally +;; bind a key to activate the link grabber menu, like this: +;; +;; (add-hook 'org-mode-hook (lambda () +;; (define-key org-mode-map (kbd "C-c g") 'omlg-grab-link))) +;; +;; +;; Usage: +;; +;; Type C-c g (or whatever key you defined, as above), or type M-x +;; omlg-grab-link RET to activate the link grabber. This will present +;; you with a menu to choose an application from which to grab a link +;; to insert at point. You may also type C-g to abort. +;; +;; Customizing: +;; +;; You may customize which applications appear in the grab menu by +;; customizing the group org-mac-link-grabber. Changes take effect +;; immediately. +;; +;; +;;; Code: + +(require 'org) +(require 'org-mac-message) + +(defgroup org-mac-link-grabber nil + "Options concerning grabbing links from external Mac +applications and inserting them in org documents" + :tag "Org Mac link grabber" + :group 'org-link) + +(defcustom org-mac-grab-Finder-app-p t + "Enable menu option [F]inder to grab links from the Finder" + :tag "Grab Finder.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Mail-app-p t + "Enable menu option [m]ail to grab links from Mail.app" + :tag "Grab Mail.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Addressbook-app-p t + "Enable menu option [a]ddressbook to grab links from AddressBook.app" + :tag "Grab AddressBook.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Safari-app-p t + "Enable menu option [s]afari to grab links from Safari.app" + :tag "Grab Safari.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Firefox-app-p t + "Enable menu option [f]irefox to grab links from Firefox.app" + :tag "Grab Firefox.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Firefox+Vimperator-p nil + "Enable menu option [v]imperator to grab links from Firefox.app running the Vimperator plugin" + :tag "Grab Vimperator/Firefox.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Chrome-app-p t + "Enable menu option [f]irefox to grab links from Google Chrome.app" + :tag "Grab Google Chrome.app links" + :group 'org-mac-link-grabber + :type 'boolean) + +(defcustom org-mac-grab-Together-app-p nil + "Enable menu option [t]ogether to grab links from Together.app" + :tag "Grab Together.app links" + :group 'org-mac-link-grabber + :type 'boolean) + + +(defun omlg-grab-link () + "Prompt the user for an application to grab a link from, then go grab the link, and insert it at point" + (interactive) + (let* ((descriptors `(("F" "inder" org-mac-finder-insert-selected ,org-mac-grab-Finder-app-p) + ("m" "ail" org-mac-message-insert-selected ,org-mac-grab-Mail-app-p) + ("a" "ddressbook" org-mac-addressbook-insert-selected ,org-mac-grab-Addressbook-app-p) + ("s" "afari" org-mac-safari-insert-frontmost-url ,org-mac-grab-Safari-app-p) + ("f" "irefox" org-mac-firefox-insert-frontmost-url ,org-mac-grab-Firefox-app-p) + ("v" "imperator" org-mac-vimperator-insert-frontmost-url ,org-mac-grab-Firefox+Vimperator-p) + ("c" "hrome" org-mac-chrome-insert-frontmost-url ,org-mac-grab-Chrome-app-p) + ("t" "ogether" org-mac-together-insert-selected ,org-mac-grab-Together-app-p))) + (menu-string (make-string 0 ?x)) + input) + + ;; Create the menu string for the keymap + (mapc '(lambda (descriptor) + (when (elt descriptor 3) + (setf menu-string (concat menu-string "[" (elt descriptor 0) "]" (elt descriptor 1) " ")))) + descriptors) + (setf (elt menu-string (- (length menu-string) 1)) ?:) + + ;; Prompt the user, and grab the link + (message menu-string) + (setq input (read-char-exclusive)) + (mapc '(lambda (descriptor) + (let ((key (elt (elt descriptor 0) 0)) + (active (elt descriptor 3)) + (grab-function (elt descriptor 2))) + (when (and active (eq input key)) + (call-interactively grab-function)))) + descriptors))) + +(defalias 'omgl-grab-link 'omlg-grab-link + "Renamed, and this alias will be obsolete next revision.") + +(defun org-mac-paste-applescript-links (as-link-list) + "Paste in a list of links from an applescript handler. The + links are of the form <link>::split::<name>" + (let* ((link-list + (mapcar + (lambda (x) (if (string-match "\\`\"\\(.*\\)\"\\'" x) (setq x (match-string 1 x))) x) + (split-string as-link-list "[\r\n]+"))) + split-link URL description orglink orglink-insert rtn orglink-list) + (while link-list + (setq split-link (split-string (pop link-list) "::split::")) + (setq URL (car split-link)) + (setq description (cadr split-link)) + (when (not (string= URL "")) + (setq orglink (org-make-link-string URL description)) + (push orglink orglink-list))) + (setq rtn (mapconcat 'identity orglink-list "\n")) + (kill-new rtn) + rtn)) + + + +;; Handle links from Firefox.app +;; +;; This code allows you to grab the current active url from the main +;; Firefox.app window, and insert it as a link into an org-mode +;; document. Unfortunately, firefox does not expose an applescript +;; dictionary, so this is necessarily introduces some limitations. +;; +;; The applescript to grab the url from Firefox.app uses the System +;; Events application to give focus to the firefox application, select +;; the contents of the url bar, and copy it. It then uses the title of +;; the window as the text of the link. There is no way to grab links +;; from other open tabs, and further, if there is more than one window +;; open, it is not clear which one will be used (though emperically it +;; seems that it is always the last active window). + +(defun as-mac-firefox-get-frontmost-url () + (let ((result (do-applescript + (concat + "set oldClipboard to the clipboard\n" + "set frontmostApplication to path to frontmost application\n" + "tell application \"Firefox\"\n" + " activate\n" + " delay 0.15\n" + " tell application \"System Events\"\n" + " keystroke \"l\" using command down\n" + " keystroke \"c\" using command down\n" + " end tell\n" + " delay 0.15\n" + " set theUrl to the clipboard\n" + " set the clipboard to oldClipboard\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (car (split-string result "[\r\n]+" t)))) + +(defun org-mac-firefox-get-frontmost-url () + (interactive) + (message "Applescript: Getting Firefox url...") + (let* ((url-and-title (as-mac-firefox-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(defun org-mac-firefox-insert-frontmost-url () + (interactive) + (insert (org-mac-firefox-get-frontmost-url))) + + +;; Handle links from Google Firefox.app running the Vimperator extension +;; Grab the frontmost url from Firefox+Vimperator. Same limitations are +;; Firefox + +(defun as-mac-vimperator-get-frontmost-url () + (let ((result (do-applescript + (concat + "set oldClipboard to the clipboard\n" + "set frontmostApplication to path to frontmost application\n" + "tell application \"Firefox\"\n" + " activate\n" + " delay 0.15\n" + " tell application \"System Events\"\n" + " keystroke \"y\"\n" + " end tell\n" + " delay 0.15\n" + " set theUrl to the clipboard\n" + " set the clipboard to oldClipboard\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (replace-regexp-in-string "\s+-\s+Vimperator" "" (car (split-string result "[\r\n]+" t))))) + + +(defun org-mac-vimperator-get-frontmost-url () + (interactive) + (message "Applescript: Getting Vimperator url...") + (let* ((url-and-title (as-mac-vimperator-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(defun org-mac-vimperator-insert-frontmost-url () + (interactive) + (insert (org-mac-vimperator-get-frontmost-url))) + + +;; Handle links from Google Chrome.app +;; Grab the frontmost url from Google Chrome. Same limitations are +;; Firefox because Chrome doesn't publish an Applescript dictionary + +(defun as-mac-chrome-get-frontmost-url () + (let ((result (do-applescript + (concat + "set oldClipboard to the clipboard\n" + "set frontmostApplication to path to frontmost application\n" + "tell application \"Google Chrome\"\n" + " activate\n" + " delay 0.15\n" + " tell application \"System Events\"\n" + " keystroke \"l\" using command down\n" + " keystroke \"c\" using command down\n" + " end tell\n" + " delay 0.15\n" + " set theUrl to the clipboard\n" + " set the clipboard to oldClipboard\n" + " set theResult to (get theUrl) & \"::split::\" & (get name of window 1)\n" + "end tell\n" + "activate application (frontmostApplication as text)\n" + "set links to {}\n" + "copy theResult to the end of links\n" + "return links as string\n")))) + (car (split-string result "[\r\n]+" t)))) + +(defun org-mac-chrome-get-frontmost-url () + (interactive) + (message "Applescript: Getting Chrome url...") + (let* ((url-and-title (as-mac-chrome-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(defun org-mac-chrome-insert-frontmost-url () + (interactive) + (insert (org-mac-chrome-get-frontmost-url))) + + +;; Handle links from Safari.app +;; Grab the frontmost url from Safari. + +(defun as-mac-safari-get-frontmost-url () + (let ((result (do-applescript + (concat + "tell application \"Safari\"\n" + " set theUrl to URL of document 1\n" + " set theName to the name of the document 1\n" + " return theUrl & \"::split::\" & theName & \"\n\"\n" + "end tell\n")))) + (car (split-string result "[\r\n]+" t)))) + +(defun org-mac-safari-get-frontmost-url () + (interactive) + (message "Applescript: Getting Safari url...") + (let* ((url-and-title (as-mac-safari-get-frontmost-url)) + (split-link (split-string url-and-title "::split::")) + (URL (car split-link)) + (description (cadr split-link)) + (org-link)) + (when (not (string= URL "")) + (setq org-link (org-make-link-string URL description))) + (kill-new org-link) + org-link)) + +(defun org-mac-safari-insert-frontmost-url () + (interactive) + (insert (org-mac-safari-get-frontmost-url))) + + +;; +;; +;; Handle links from together.app +;; +;; + +(org-add-link-type "x-together-item" 'org-mac-together-item-open) + +(defun org-mac-together-item-open (uid) + "Open the given uid, which is a reference to an item in Together" + (shell-command (concat "open -a Together \"x-together-item:" uid "\""))) + +(defun as-get-selected-together-items () + (do-applescript + (concat + "tell application \"Together\"\n" + " set theLinkList to {}\n" + " set theSelection to selected items\n" + " repeat with theItem in theSelection\n" + " set theLink to (get item link of theItem) & \"::split::\" & (get name of theItem) & \"\n\"\n" + " copy theLink to end of theLinkList\n" + " end repeat\n" + " return theLinkList as string\n" + "end tell"))) + +(defun org-mac-together-get-selected () + (interactive) + (message "Applescript: Getting Togther items...") + (org-mac-paste-applescript-links (as-get-selected-together-items))) + +(defun org-mac-together-insert-selected () + (interactive) + (insert (org-mac-together-get-selected))) + + +;; +;; +;; Handle links from Finder.app +;; +;; + +(defun as-get-selected-finder-items () + (do-applescript +(concat +"tell application \"Finder\"\n" +" set theSelection to the selection\n" +" set links to {}\n" +" repeat with theItem in theSelection\n" +" set theLink to \"file://\" & (POSIX path of (theItem as string)) & \"::split::\" & (get the name of theItem) & \"\n\"\n" +" copy theLink to the end of links\n" +" end repeat\n" +" return links as string\n" +"end tell\n"))) + +(defun org-mac-finder-item-get-selected () + (interactive) + (message "Applescript: Getting Finder items...") + (org-mac-paste-applescript-links (as-get-selected-finder-items))) + +(defun org-mac-finder-insert-selected () + (interactive) + (insert (org-mac-finder-item-get-selected))) + + +;; +;; +;; Handle links from AddressBook.app +;; +;; + +(org-add-link-type "addressbook" 'org-mac-addressbook-item-open) + +(defun org-mac-addressbook-item-open (uid) + "Open the given uid, which is a reference to an item in Together" + (shell-command (concat "open \"addressbook:" uid "\""))) + +(defun as-get-selected-addressbook-items () + (do-applescript + (concat + "tell application \"Address Book\"\n" + " set theSelection to the selection\n" + " set links to {}\n" + " repeat with theItem in theSelection\n" + " set theLink to \"addressbook://\" & (the id of theItem) & \"::split::\" & (the name of theItem) & \"\n\"\n" + " copy theLink to the end of links\n" + " end repeat\n" + " return links as string\n" + "end tell\n"))) + +(defun org-mac-addressbook-item-get-selected () + (interactive) + (message "Applescript: Getting Address Book items...") + (org-mac-paste-applescript-links (as-get-selected-addressbook-items))) + +(defun org-mac-addressbook-insert-selected () + (interactive) + (insert (org-mac-addressbook-item-get-selected))) + + +(provide 'org-mac-link-grabber) + +;;; org-mac-link-grabber.el ends here diff --git a/contrib/lisp/org-mairix.el b/contrib/lisp/org-mairix.el new file mode 100644 index 0000000..367a866 --- /dev/null +++ b/contrib/lisp/org-mairix.el @@ -0,0 +1,332 @@ +;;; org-mairix.el - Support for hooking mairix search into Org for different MUAs +;; +;; Copyright (C) 2007-2012 Georg C. F. Greve +;; mutt support by Adam Spiers <orgmode at adamspiers dot org> +;; +;; Author: Georg C. F. Greve <greve at fsfeurope dot org> +;; Keywords: outlines, hypermedia, calendar, wp, email, mairix +;; Purpose: Integrate mairix email searching into Org mode +;; See http://orgmode.org and http://www.rpcurnow.force9.co.uk/mairix/ +;; Version: 0.5 +;; +;; This file is Free Software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; It is distributed in the hope that it will be useful, but WITHOUT +;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +;; License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; USAGE NOTE +;; +;; You will need to configure mairix first, which involves setting up your +;; .mairixrc in your home directory. Once it is working, you should set up +;; your way to display results in your favorite way -- usually a MUA. +;; Currently gnus and mutt are supported. +;; +;; After both steps are done, all you should need to hook mairix, org +;; and your MUA together is to do (require 'org-mairix) in your +;; startup file. Everything can then be configured normally through +;; Emacs customisation. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'org) + +;;; The custom variables + +(defgroup org-mairix nil + "Mairix support/integration in org." + :tag "Org Mairix" + :group 'org) + +(defcustom org-mairix-threaded-links t + "Should new links be created as threaded links? +If t, links will be stored as threaded searches. +If nil, links will be stored as non-threaded searches." + :group 'org-mairix + :type 'boolean) + +(defcustom org-mairix-augmented-links nil + "Should new links be created as augmenting searches? +If t, links will be stored as augmenting searches. +If nil, links will be stored as normal searches. + +Attention: When activating this option, you will need +to remove old articles from your mairix results group +in some other way, mairix will not do it for you." + :group 'org-mairix + :type 'boolean) + +(defcustom org-mairix-display-hook 'org-mairix-gnus-display-results + "Hook to call to display the results of a successful mairix search. +Defaults to Gnus, feel free to add your own MUAs or methods." + :group 'org-mairix + :type 'hook) + +(defcustom org-mairix-open-command "mairix %args% '%search%'" + "The mairix command-line to use. If your paths are set up +correctly, you should not need to change this. + +'%search%' will get substituted with the search expression, and +'%args%' with any additional arguments." + :group 'org-mairix + :type 'string) + +;;; The hooks to integrate mairix into org + +(org-add-link-type "mairix" 'org-mairix-open) +(add-hook 'org-store-link-functions 'org-mairix-store-gnus-link) + +;;; Generic org-mairix functions + +(defun org-mairix-construct-link (message-id) + "Construct a mairix: hyperlink based on message-id." + (concat "mairix:" + (if org-mairix-threaded-links "t:") + (if org-mairix-augmented-links "a:") + "@@" + (org-remove-angle-brackets message-id))) + +(defun org-store-mairix-link-props (&rest plist) + "Take a property list describing a mail, and add mairix link +and description properties so that org can build a mairix link to +it." + ;; We have to call `org-store-link-props' twice: + ;; + ;; - It extracts 'fromname'/'fromaddress' from 'from' property, + ;; and stores the updated plist to `org-store-link-plist'. + ;; + ;; - `org-email-link-description' uses these new properties to + ;; build a description from the previously stored plist. I + ;; wrote a tiny patch to `org-email-link-description' so it + ;; could take a non-stored plist as an optional 2nd argument, + ;; but the plist provided still needs 'fromname'/'fromaddress'. + ;; + ;; - Ideally we would decouple the storing bit of + ;; `org-store-link-props' from the extraction bit, but lots of + ;; stuff in `org-store-link' which calls it would need to be + ;; changed. Maybe just factor out the extraction so it can be + ;; reused separately? + (let ((mid (plist-get plist :message-id))) + (apply 'org-store-link-props + (append plist + (list :type "mairix" + :link (org-mairix-construct-link mid)))) + (apply 'org-store-link-props + (append org-store-link-plist + (list :description (org-email-link-description)))))) + +(defun org-mairix-message-send-and-exit-with-link () + "Function that can be assigned as an alternative sending function, +it sends the message and then stores a mairix link to it before burying +the buffer just like 'message-send-and-exit' does." + (interactive) + (message-send) + (let* ((message-id (message-fetch-field "Message-Id")) + (subject (message-fetch-field "Subject")) + (link (org-mairix-construct-link message-id)) + (desc (concat "Email: '" subject "'"))) + (setq org-stored-links + (cons (list link desc) org-stored-links))) + (message-bury (current-buffer))) + +(defun org-mairix-open (search) + "Function to open mairix link. + +We first need to split it into its individual parts, and then +extract the message-id to be passed on to the display function +before call mairix, evaluate the number of matches returned, and +make sure to only call display of mairix succeeded in matching." + (let* ((args "")) + (if (equal (substring search 0 2) "t:" ) + (progn (setq search (substring search 2 nil)) + (setq args (concat args " --threads")))) + (if (equal (substring search 0 2) "a:") + (progn (setq search (substring search 2 nil)) + (setq args (concat args " --augment")))) + (let ((cmdline (org-mairix-command-substitution + org-mairix-open-command search args))) + (print cmdline) + (setq retval (shell-command-to-string cmdline)) + (string-match "\[0-9\]+" retval) + (setq matches (string-to-number (match-string 0 retval))) + (if (eq matches 0) (message "Link failed: no matches, sorry") + (message "Link returned %d matches" matches) + (run-hook-with-args 'org-mairix-display-hook search args))))) + +(defun org-mairix-command-substitution (cmd search args) + "Substitute '%search%' and '%args% in mairix search command." + (while (string-match "%search%" cmd) + (setq cmd (replace-match search 'fixedcase 'literal cmd))) + (while (string-match "%args%" cmd) + (setq cmd (replace-match args 'fixedcase 'literal cmd))) + cmd) + +;;; Functions necessary for integration of external MUAs. + +;; Of course we cannot call `org-store-link' from within an external +;; MUA, so we need some other way of storing a link for later +;; retrieval by org-mode and/or remember-mode. To do this we use a +;; temporary file as a kind of dedicated clipboard. + +(defcustom org-mairix-link-clipboard "~/.org-mairix-link" + "Pseudo-clipboard file where mairix URLs get copied to by external +applications in order to mimic `org-store-link'. Used by +`org-mairix-insert-link'." + :group 'org-mairix + :type 'string) + +;; When we resolve some of the issues with `org-store-link' detailed +;; at <http://thread.gmane.org/gmane.emacs.orgmode/4217/focus=4635>, +;; we might not need org-mairix-insert-link. + +(defun org-mairix-insert-link () + "Insert link from file defined by `org-mairix-link-clipboard'." + (interactive) + (let ((bytes (cadr (insert-file-contents + (expand-file-name org-mairix-link-clipboard))))) + (forward-char bytes) + (save-excursion + (forward-char -1) + (if (looking-at "\n") + (delete-char 1))))) + +;;; Functions necessary for mutt integration + +(defgroup org-mairix-mutt nil + "Use mutt for mairix support in org." + :tag "Org Mairix Mutt" + :group 'org-mairix) + +(defcustom org-mairix-mutt-display-command + "xterm -title 'mairix search: %search%' -e 'unset COLUMNS; mutt -f +~/mail/mairix -e \"push <display-message>\"' &" + "Command to execute to display mairix search results via mutt within +an xterm. + +'%search%' will get substituted with the search expression, and +'%args%' with any additional arguments used in the search." + :group 'org-mairix-mutt + :type 'string) + +(defun org-mairix-mutt-display-results (search args) + "Display results of mairix search in mutt, using the command line +defined in `org-mairix-mutt-display-command'." + ;; By default, async `shell-command' invocations display the temp + ;; buffer, which is annoying here. We choose a deterministic + ;; buffer name so we can hide it again immediately. + ;; Note: `call-process' is synchronous so not useful here. + (let ((cmd (org-mairix-command-substitution + org-mairix-mutt-display-command search args)) + (tmpbufname (generate-new-buffer-name " *mairix-view*"))) + (shell-command cmd tmpbufname) + (delete-windows-on (get-buffer tmpbufname)))) + +;;; Functions necessary for gnus integration + +(defgroup org-mairix-gnus nil + "Use gnus for mairix support in org." + :tag "Org Mairix Gnus" + :group 'org-mairix) + +(defcustom org-mairix-gnus-results-group "nnmaildir:mairix" + "The group that is configured to hold the mairix search results, +which needs to be setup independently of the org-mairix integration, +along with general mairix configuration." + :group 'org-mairix-gnus + :type 'string) + +(defcustom org-mairix-gnus-select-display-group-function +'org-mairix-gnus-select-display-group-function-gg + "Hook to call to select the group that contains the matching articles. +We should not need this, it is owed to a problem of gnus that people were +not yet able to figure out, see + http://article.gmane.org/gmane.emacs.gnus.general/65248 + http://article.gmane.org/gmane.emacs.gnus.general/65265 + http://article.gmane.org/gmane.emacs.gnus.user/9596 +for reference. + +It seems gnus needs a 'forget/ignore everything you think you +know about that group' function. Volunteers?" + :group 'org-mairix-gnus + :type 'hook) + +(defun org-mairix-store-gnus-link () + "Store a link to the current gnus message as a Mairix search for its +Message ID." + + ;; gnus integration + (when (memq major-mode '(gnus-summary-mode gnus-article-mode)) + (and (eq major-mode 'gnus-article-mode) (gnus-article-show-summary)) + (let* ((article (gnus-summary-article-number)) + (header (gnus-summary-article-header article)) + (from (mail-header-from header)) + (message-id (mail-header-id header)) + (subject (gnus-summary-subject-string))) + (org-store-mairix-link-props :from from + :subject subject + :message-id message-id)))) + +(defun org-mairix-gnus-display-results (search args) + "Display results of mairix search in Gnus. + +Note: This does not work as cleanly as I would like it to. The +problem being that Gnus should simply reread the group cleanly, +without remembering anything. At the moment it seems to be unable +to do that -- so you're likely to see zombies floating around. + +If you can improve this, please do!" + (if (not (equal (substring search 0 2) "m:" )) + (error "org-mairix-gnus-display-results: display of search other than +message-id not implemented yet")) + (setq message-id (substring search 2 nil)) + (require 'gnus) + (require 'gnus-sum) + ;; FIXME: (bzg/gg) We might need to make sure gnus is running here, + ;; and to start it in case it isn't running already. Does + ;; anyone know a function to do that? It seems main org mode + ;; does not do this, either. + (funcall (cdr (assq 'gnus org-link-frame-setup))) + (if gnus-other-frame-object (select-frame gnus-other-frame-object)) + + ;; FIXME: This is horribly broken. Please see + ;; http://article.gmane.org/gmane.emacs.gnus.general/65248 + ;; http://article.gmane.org/gmane.emacs.gnus.general/65265 + ;; http://article.gmane.org/gmane.emacs.gnus.user/9596 + ;; for reference. + ;; + ;; It seems gnus needs a "forget/ignore everything you think you + ;; know about that group" function. Volunteers? + ;; + ;; For now different methods seem to work differently well for + ;; different people. So we're playing hook-selection here to make + ;; it easy to play around until we found a proper solution. + (run-hook-with-args 'org-mairix-gnus-select-display-group-function) + (gnus-summary-select-article + nil t t (car (gnus-find-matching-articles "message-id" message-id)))) + +(defun org-mairix-gnus-select-display-group-function-gg () + "Georg's hack to select a group that gnus (falsely) believes to be +empty to then call rebuilding of the summary. It leaves zombies of +old searches around, though." + (gnus-group-quick-select-group 0 org-mairix-gnus-results-group) + (gnus-group-clear-data) + (gnus-summary-reselect-current-group t t)) + +(defun org-mairix-gnus-select-display-group-function-bzg () + "This is the classic way the org mode is using, and it seems to be +using better for Bastien, so it may work for you." + (gnus-group-clear-data org-mairix-gnus-results-group) + (gnus-group-read-group t nil org-mairix-gnus-results-group)) + +(provide 'org-mairix) + +;;; org-mairix.el ends here diff --git a/contrib/lisp/org-man.el b/contrib/lisp/org-man.el new file mode 100644 index 0000000..27e8cca --- /dev/null +++ b/contrib/lisp/org-man.el @@ -0,0 +1,64 @@ +;;; org-man.el - Support for links to manpages in Org-mode +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 1.0 +;; +;; This file is not yet part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +(require 'org) + +(org-add-link-type "man" 'org-man-open) +(add-hook 'org-store-link-functions 'org-man-store-link) + +(defcustom org-man-command 'man + "The Emacs command to be used to display a man page." + :group 'org-link + :type '(choice (const man) (const woman))) + +(defun org-man-open (path) + "Visit the manpage on PATH. +PATH should be a topic that can be thrown at the man command." + (funcall org-man-command path)) + +(defun org-man-store-link () + "Store a link to a README file." + (when (memq major-mode '(Man-mode woman-mode)) + ;; This is a man page, we do make this link + (let* ((page (org-man-get-page-name)) + (link (concat "man:" page)) + (description (format "Manpage for %s" page))) + (org-store-link-props + :type "man" + :link link + :description description)))) + +(defun org-man-get-page-name () + "Extract the page name from the buffer name." + ;; This works for both `Man-mode' and `woman-mode'. + (if (string-match " \\(\\S-+\\)\\*" (buffer-name)) + (match-string 1 (buffer-name)) + (error "Cannot create link to this man page"))) + +(provide 'org-man) + +;;; org-man.el ends here diff --git a/contrib/lisp/org-md.el b/contrib/lisp/org-md.el new file mode 100644 index 0000000..4579ca3 --- /dev/null +++ b/contrib/lisp/org-md.el @@ -0,0 +1,461 @@ +;;; org-md.el --- Markdown Back-End for Org Export Engine + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Nicolas Goaziou <n.goaziou@gmail.com> +;; Keywords: org, wp, tex + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This library implements a Markdown back-end (vanilla flavour) for +;; Org exporter, based on `e-html'. +;; +;; It provides two commands for export, depending on the desired +;; output: `org-md-export-as-markdown' (temporary buffer) and +;; `org-md-export-to-markdown' ("md" file). + +;;; Code: + +(require 'org-e-html) + + + +;;; User-Configurable Variables + +(defgroup org-export-md nil + "Options specific to Markdown export back-end." + :tag "Org Markdown" + :group 'org-export + :version "24.2") + +(defcustom org-md-headline-style 'atx + "Style used to format headlines. +This variable can be set to either `atx' or `setext'." + :group 'org-export-md + :type '(choice + (const :tag "Use \"atx\" style" atx) + (const :tag "Use \"Setext\" style" setext))) + + + +;;; Define Back-End + +(org-export-define-derived-backend md e-html + :export-block ("MD" "MARKDOWN") + :filters-alist ((:filter-parse-tree . org-md-separate-elements)) + :translate-alist ((bold . org-md-bold) + (code . org-md-verbatim) + (example-block . org-md-example-block) + (footnote-definition . ignore) + (footnote-reference . ignore) + (headline . org-md-headline) + (horizontal-rule . org-md-horizontal-rule) + (inline-src-block . org-md-verbatim) + (italic . org-md-italic) + (item . org-md-item) + (line-break . org-md-line-break) + (link . org-md-link) + (paragraph . org-md-paragraph) + (plain-list . org-md-plain-list) + (plain-text . org-md-plain-text) + (quote-block . org-md-quote-block) + (quote-section . org-md-example-block) + (section . org-md-section) + (src-block . org-md-example-block) + (template . org-md-template) + (verbatim . org-md-verbatim))) + + + +;;; Filters + +(defun org-md-separate-elements (tree backend info) + "Make sure elements are separated by at least one blank line. + +TREE is the parse tree being exported. BACKEND is the export +back-end used. INFO is a plist used as a communication channel. + +Assume BACKEND is `md'." + (org-element-map + tree org-element-all-elements + (lambda (elem) + (unless (eq (org-element-type elem) 'org-data) + (org-element-put-property + elem :post-blank + (let ((post-blank (org-element-property :post-blank elem))) + (if (not post-blank) 1 (max 1 post-blank))))))) + ;; Return updated tree. + tree) + + + +;;; Transcode Functions + +;;;; Bold + +(defun org-md-bold (bold contents info) + "Transcode BOLD object into Markdown format. +CONTENTS is the text within bold markup. INFO is a plist used as +a communication channel." + (format "**%s**" contents)) + + +;;;; Code and Verbatim + +(defun org-md-verbatim (verbatim contents info) + "Transcode VERBATIM object into Markdown format. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (let ((value (org-element-property :value verbatim))) + (format (cond ((not (string-match "`" value)) "`%s`") + ((or (string-match "\\``" value) + (string-match "`\\'" value)) + "`` %s ``") + (t "``%s``")) + value))) + + +;;;; Example Block and Src Block + +(defun org-md-example-block (example-block contents info) + "Transcode EXAMPLE-BLOCK element into Markdown format. +CONTENTS is nil. INFO is a plist used as a communication +channel." + (replace-regexp-in-string + "^" " " + (org-remove-indentation + (org-element-property :value example-block)))) + + +;;;; Headline + +(defun org-md-headline (headline contents info) + "Transcode HEADLINE element into Markdown format. +CONTENTS is the headline contents. INFO is a plist used as +a communication channel." + (unless (org-element-property :footnote-section-p headline) + (let* ((level (org-export-get-relative-level headline info)) + (title (org-export-data (org-element-property :title headline) info)) + (todo (and (plist-get info :with-todo-keywords) + (let ((todo (org-element-property :todo-keyword + headline))) + (and todo (concat (org-export-data todo info) " "))))) + (tags (and (plist-get info :with-tags) + (let ((tag-list (org-export-get-tags headline info))) + (and tag-list + (format " :%s:" + (mapconcat 'identity tag-list ":")))))) + (priority + (and (plist-get info :with-priority) + (let ((char (org-element-property :priority headline))) + (and char (format "[#%c] " char))))) + ;; Headline text without tags. + (heading (concat todo priority title))) + (cond + ;; Cannot create an headline. Fall-back to a list. + ((or (org-export-low-level-p headline info) + (not (memq org-md-headline-style '(atx setext))) + (and (eq org-md-headline-style 'atx) (> level 6)) + (and (eq org-md-headline-style 'setext) (> level 2))) + (let ((bullet + (if (not (org-export-numbered-headline-p headline info)) "-" + (concat (number-to-string + (car (last (org-export-get-headline-number + headline info)))) + ".")))) + (concat bullet (make-string (- 4 (length bullet)) ? ) heading tags + "\n\n" + (and contents + (replace-regexp-in-string "^" " " contents))))) + ;; Use "Setext" style. + ((eq org-md-headline-style 'setext) + (concat heading tags "\n" + (make-string (length heading) (if (= level 1) ?= ?-)) + "\n\n" + contents)) + ;; Use "atx" style. + (t (concat (make-string level ?#) " " heading tags "\n\n" contents)))))) + + +;;;; Horizontal Rule + +(defun org-md-horizontal-rule (horizontal-rule contents info) + "Transcode HORIZONTAL-RULE element into Markdown format. +CONTENTS is the horizontal rule contents. INFO is a plist used +as a communication channel." + "---") + + +;;;; Italic + +(defun org-md-italic (italic contents info) + "Transcode ITALIC object into Markdown format. +CONTENTS is the text within italic markup. INFO is a plist used +as a communication channel." + (format "*%s*" contents)) + + +;;;; Item + +(defun org-md-item (item contents info) + "Transcode ITEM element into Markdown format. +CONTENTS is the item contents. INFO is a plist used as +a communication channel." + (let* ((type (org-element-property :type (org-export-get-parent item))) + (struct (org-element-property :structure item)) + (bullet (if (not (eq type 'ordered)) "-" + (concat (number-to-string + (car (last (org-list-get-item-number + (org-element-property :begin item) + struct + (org-list-prevs-alist struct) + (org-list-parents-alist struct))))) + ".")))) + (concat bullet + (make-string (- 4 (length bullet)) ? ) + (case (org-element-property :checkbox item) + (on "[X] ") + (trans "[-] ") + (off "[ ] ")) + (let ((tag (org-element-property :tag item))) + (and tag (format "**%s:** "(org-export-data tag info)))) + (org-trim (replace-regexp-in-string "^" " " contents))))) + + +;;;; Line Break + +(defun org-md-line-break (line-break contents info) + "Transcode LINE-BREAK object into Markdown format. +CONTENTS is nil. INFO is a plist used as a communication +channel." + " ") + + +;;;; Link + +(defun org-md-link (link contents info) + "Transcode LINE-BREAK object into Markdown format. +CONTENTS is the link's description. INFO is a plist used as +a communication channel." + (let ((--link-org-files-as-html-maybe + (function + (lambda (raw-path info) + ;; Treat links to `file.org' as links to `file.html', if + ;; needed. See `org-e-html-link-org-files-as-html'. + (cond + ((and org-e-html-link-org-files-as-html + (string= ".org" + (downcase (file-name-extension raw-path ".")))) + (concat (file-name-sans-extension raw-path) "." + (plist-get info :html-extension))) + (t raw-path))))) + (type (org-element-property :type link))) + (cond ((member type '("custom-id" "id")) + (let ((destination (org-export-resolve-id-link link info))) + (if (stringp destination) ; External file. + (let ((path (funcall --link-org-files-as-html-maybe + destination info))) + (if (not contents) (format "<%s>" path) + (format "[%s](%s)" contents path))) + (concat + (and contents (concat contents " ")) + (format "(%s)" + (format (org-export-translate "See section %s" :html info) + (mapconcat 'number-to-string + (org-export-get-headline-number + destination info) + "."))))))) + ((org-export-inline-image-p link org-e-html-inline-image-rules) + (format "" + (let ((caption + (org-element-property + :caption (org-export-get-parent-element link)))) + (when caption (org-export-data (car caption) info))) + path)) + ((string= type "coderef") + (let ((ref (org-element-property :path link))) + (format (org-export-get-coderef-format ref contents) + (org-export-resolve-coderef ref info)))) + ((equal type "radio") + (let ((destination (org-export-resolve-radio-link link info))) + (org-export-data (org-element-contents destination) info))) + ((equal type "fuzzy") + (let ((destination (org-export-resolve-fuzzy-link link info))) + ;; Ignore invisible "#+TARGET: path". + (unless (eq (org-element-type destination) 'keyword) + (if (org-string-nw-p contents) contents + (when destination + (let ((number (org-export-get-ordinal destination info))) + (when number + (if (atom number) (number-to-string number) + (mapconcat 'number-to-string number "."))))))))) + (t (let* ((raw-path (org-element-property :path link)) + (path (cond + ((member type '("http" "https" "ftp")) + (concat type ":" raw-path)) + ((equal type "file") + ;; Extract just the file path and strip + ;; all other components. + (when (string-match "\\(.+\\)::.+" raw-path) + (setq raw-path (match-string 1 raw-path))) + ;; Treat links to ".org" files as ".html", + ;; if needed. + (setq raw-path + (funcall --link-org-files-as-html-maybe + raw-path info)) + ;; If file path is absolute, prepend it + ;; with protocol component - "file://". + (if (not (file-name-absolute-p raw-path)) raw-path + (concat "file://" (expand-file-name raw-path)))) + (t raw-path)))) + (if (not contents) (format "<%s>" path) + (format "[%s](%s)" contents path))))))) + + +;;;; Paragraph + +(defun org-md-paragraph (paragraph contents info) + "Transcode PARAGRAPH element into Markdown format. +CONTENTS is the paragraph contents. INFO is a plist used as +a communication channel." + (let ((first-object (car (org-element-contents paragraph)))) + ;; If paragraph starts with a #, protect it. + (if (and (stringp first-object) (string-match "\\`#" first-object)) + (replace-regexp-in-string "\\`#" "\\#" contents nil t) + contents))) + + +;;;; Plain List + +(defun org-md-plain-list (plain-list contents info) + "Transcode PLAIN-LIST element into Markdown format. +CONTENTS is the plain-list contents. INFO is a plist used as +a communication channel." + contents) + + +;;;; Plain Text + +(defun org-md-plain-text (text info) + "Transcode a TEXT string into Markdown format. +TEXT is the string to transcode. INFO is a plist holding +contextual information." + ;; Protect ambiguous #. This will protect # at the beginning of + ;; a line, but not at the beginning of a paragraph. See + ;; `org-md-paragraph'. + (setq text (replace-regexp-in-string "\n#" "\n\\\\#" text)) + ;; Protect ambiguous ! + (setq text (replace-regexp-in-string "\\(!\\)\\[" "\\\\!" text nil nil 1)) + ;; Protect `, *, _ and \ + (setq text + (replace-regexp-in-string + "[`*_\\]" (lambda (rep) (concat "\\\\" (match-string 1 rep))) text)) + ;; Handle special strings, if required. + (when (plist-get info :with-special-strings) + (setq text (org-e-html-convert-special-strings text))) + ;; Handle break preservation, if required. + (when (plist-get info :preserve-breaks) + (setq text (replace-regexp-in-string "[ \t]*\n" " \n" text))) + ;; Return value. + text) + + +;;;; Quote Block + +(defun org-md-quote-block (quote-block contents info) + "Transcode QUOTE-BLOCK element into Markdown format. +CONTENTS is the quote-block contents. INFO is a plist used as +a communication channel." + (replace-regexp-in-string + "^" "> " + (replace-regexp-in-string "\n\\'" "" contents))) + + +;;;; Section + +(defun org-md-section (section contents info) + "Transcode SECTION element into Markdown format. +CONTENTS is the section contents. INFO is a plist used as +a communication channel." + contents) + + +;;;; Template + +(defun org-md-template (contents info) + "Return complete document string after Markdown conversion. +CONTENTS is the transcoded contents string. INFO is a plist used +as a communication channel." + contents) + + + +;;; Interactive function + +;;;###autoload +(defun org-md-export-as-markdown (&optional subtreep visible-only) + "Export current buffer to a text buffer. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +Export is done in a buffer named \"*Org MD Export*\", which will +be displayed when `org-export-show-temporary-export-buffer' is +non-nil." + (interactive) + (let ((outbuf (org-export-to-buffer + 'md "*Org MD Export*" subtreep visible-only))) + (with-current-buffer outbuf (text-mode)) + (when org-export-show-temporary-export-buffer + (switch-to-buffer-other-window outbuf)))) + + +;;;###autoload +(defun org-md-export-to-markdown (&optional subtreep visible-only pub-dir) + "Export current buffer to a Markdown file. + +If narrowing is active in the current buffer, only export its +narrowed part. + +If a region is active, export that region. + +When optional argument SUBTREEP is non-nil, export the sub-tree +at point, extracting information from the headline properties +first. + +When optional argument VISIBLE-ONLY is non-nil, don't export +contents of hidden elements. + +When optional argument PUB-DIR is set, use it as the publishing +directory. + +Return output file's name." + (interactive) + (let ((outfile (org-export-output-file-name ".md" subtreep pub-dir))) + (org-export-to-file 'md outfile subtreep visible-only))) + + +(provide 'org-md) +;;; org-md.el ends here diff --git a/contrib/lisp/org-mime.el b/contrib/lisp/org-mime.el new file mode 100644 index 0000000..fc333be --- /dev/null +++ b/contrib/lisp/org-mime.el @@ -0,0 +1,336 @@ +;;; org-mime.el --- org html export for text/html MIME emails + +;; Copyright (C) 2010-2012 Eric Schulte + +;; Author: Eric Schulte +;; Keywords: mime, mail, email, html +;; Homepage: http://orgmode.org/worg/org-contrib/org-mime.php +;; Version: 0.01 + +;; This file is not part of GNU Emacs. + +;;; License: + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; WYSWYG, html mime composition using org-mode +;; +;; For mail composed using the orgstruct-mode minor mode, this +;; provides a function for converting all or part of your mail buffer +;; to embedded html as exported by org-mode. Call `org-mime-htmlize' +;; in a message buffer to convert either the active region or the +;; entire buffer to html. +;; +;; Similarly the `org-mime-org-buffer-htmlize' function can be called +;; from within an org-mode buffer to convert the buffer to html, and +;; package the results into an email handling with appropriate MIME +;; encoding. +;; +;; you might want to bind this to a key with something like the +;; following message-mode binding +;; +;; (add-hook 'message-mode-hook +;; (lambda () +;; (local-set-key "\C-c\M-o" 'org-mime-htmlize))) +;; +;; and the following org-mode binding +;; +;; (add-hook 'org-mode-hook +;; (lambda () +;; (local-set-key "\C-c\M-o" 'org-mime-org-buffer-htmlize))) + +;;; Code: +(require 'cl) + +(defcustom org-mime-use-property-inheritance nil + "Non-nil means al MAIL_ properties apply also for sublevels." + :group 'org-mime + :type 'boolean) + +(defcustom org-mime-default-header + "#+OPTIONS: latex:t\n" + "Default header to control html export options, and ensure + first line isn't assumed to be a title line." + :group 'org-mime + :type 'string) + +(defcustom org-mime-library 'mml + "Library to use for marking up MIME elements." + :group 'org-mime + :type '(choice 'mml 'semi 'vm)) + +(defcustom org-mime-preserve-breaks t + "Used as temporary value of `org-export-preserve-breaks' during + mime encoding." + :group 'org-mime + :type 'boolean) + +(defcustom org-mime-fixedwith-wrap + "<pre style=\"font-family: courier, monospace;\">\n%s</pre>\n" + "Format string used to wrap a fixedwidth HTML email." + :group 'org-mime + :type 'string) + +(defcustom org-mime-html-hook nil + "Hook to run over the html buffer before attachment to email. + This could be used for example to post-process html elements." + :group 'org-mime + :type 'hook) + +(mapc (lambda (fmt) + (eval `(defcustom + ,(intern (concat "org-mime-pre-" fmt "-hook")) + nil + (concat "Hook to run before " fmt " export.\nFunctions " + "should take no arguments and will be run in a " + "buffer holding\nthe text to be exported.")))) + '("ascii" "org" "html")) + +(defcustom org-mime-send-subtree-hook nil + "Hook to run in the subtree in the Org-mode file before export.") + +(defcustom org-mime-send-buffer-hook nil + "Hook to run in the Org-mode file before export.") + +;; example hook, for setting a dark background in <pre style="background-color: #EEE;"> elements +(defun org-mime-change-element-style (element style) + "Set new default htlm style for <ELEMENT> elements in exported html." + (while (re-search-forward (format "<%s" element) nil t) + (replace-match (format "<%s style=\"%s\"" element style)))) + +(defun org-mime-change-class-style (class style) + "Set new default htlm style for objects with classs=CLASS in +exported html." + (while (re-search-forward (format "class=\"%s\"" class) nil t) + (replace-match (format "class=\"%s\" style=\"%s\"" class style)))) + +;; ;; example addition to `org-mime-html-hook' adding a dark background +;; ;; color to <pre> elements +;; (add-hook 'org-mime-html-hook +;; (lambda () +;; (org-mime-change-element-style +;; "pre" (format "color: %s; background-color: %s;" +;; "#E6E1DC" "#232323")) +;; (org-mime-change-class-style +;; "verse" "border-left: 2px solid gray; padding-left: 4px;"))) + +(defun org-mime-file (ext path id) + "Markup a file for attachment." + (case org-mime-library + ('mml (format (concat "<#part type=\"%s\" filename=\"%s\" " + "disposition=inline id=\"<%s>\">\n<#/part>\n") + ext path id)) + ('semi (concat + (format (concat "--[[%s\nContent-Disposition: " + "inline;\nContent-ID: <%s>][base64]]\n") + ext id) + (base64-encode-string + (with-temp-buffer + (set-buffer-multibyte nil) + (binary-insert-encoded-file path) + (buffer-string))))) + ('vm "?"))) + +(defun org-mime-multipart (plain html &optional images) + "Markup a multipart/alternative with text/plain and text/html alternatives. +If the html portion of the message includes images wrap the html +and images in a multipart/related part." + (case org-mime-library + ('mml (concat "<#multipart type=alternative><#part type=text/plain>" + plain + (when images "<#multipart type=related>") + "<#part type=text/html>" + html + images + (when images "<#/multipart>\n") + "<#/multipart>\n")) + ('semi (concat + "--" "<<alternative>>-{\n" + "--" "[[text/plain]]\n" plain + (when images (concat "--" "<<alternative>>-{\n")) + "--" "[[text/html]]\n" html + images + (when images (concat "--" "}-<<alternative>>\n")) + "--" "}-<<alternative>>\n")) + ('vm "?"))) + +(defun org-mime-replace-images (str current-file) + "Replace images in html files with cid links." + (let (html-images) + (cons + (replace-regexp-in-string ;; replace images in html + "src=\"\\([^\"]+\\)\"" + (lambda (text) + (format + "src=\"cid:%s\"" + (let* ((url (and (string-match "src=\"\\([^\"]+\\)\"" text) + (match-string 1 text))) + (path (expand-file-name + url (file-name-directory current-file))) + (ext (file-name-extension path)) + (id (replace-regexp-in-string "[\/\\\\]" "_" path))) + (add-to-list 'html-images + (org-mime-file (concat "image/" ext) path id)) + id))) + str) + html-images))) + +(defun org-mime-htmlize (arg) + "Export a portion of an email body composed using `mml-mode' to +html using `org-mode'. If called with an active region only +export that region, otherwise export the entire body." + (interactive "P") + (let* ((region-p (org-region-active-p)) + (html-start (or (and region-p (region-beginning)) + (save-excursion + (goto-char (point-min)) + (search-forward mail-header-separator) + (+ (point) 1)))) + (html-end (or (and region-p (region-end)) + ;; TODO: should catch signature... + (point-max))) + (raw-body (buffer-substring html-start html-end)) + (tmp-file (make-temp-name (expand-file-name + "mail" temporary-file-directory))) + (body (org-export-string raw-body 'org (file-name-directory tmp-file))) + ;; because we probably don't want to skip part of our mail + (org-export-skip-text-before-1st-heading nil) + ;; because we probably don't want to export a huge style file + (org-export-htmlize-output-type 'inline-css) + ;; makes the replies with ">"s look nicer + (org-export-preserve-breaks org-mime-preserve-breaks) + ;; dvipng for inline latex because MathJax doesn't work in mail + (org-export-with-LaTeX-fragments 'dvipng) + ;; to hold attachments for inline html images + (html-and-images + (org-mime-replace-images + (org-export-string raw-body 'html (file-name-directory tmp-file)) + tmp-file)) + (html-images (unless arg (cdr html-and-images))) + (html (org-mime-apply-html-hook + (if arg + (format org-mime-fixedwith-wrap body) + (car html-and-images))))) + (delete-region html-start html-end) + (save-excursion + (goto-char html-start) + (insert (org-mime-multipart + body html (mapconcat 'identity html-images "\n")))))) + +(defun org-mime-apply-html-hook (html) + (if org-mime-html-hook + (with-temp-buffer + (insert html) + (goto-char (point-min)) + (run-hooks 'org-mime-html-hook) + (buffer-string)) + html)) + +(defmacro org-mime-try (&rest body) + `(condition-case nil ,@body (error nil))) + +(defun org-mime-send-subtree (&optional fmt) + (save-restriction + (org-narrow-to-subtree) + (run-hooks 'org-mime-send-subtree-hook) + (flet ((mp (p) (org-entry-get nil p org-mime-use-property-inheritance))) + (let* ((file (buffer-file-name (current-buffer))) + (subject (or (mp "MAIL_SUBJECT") (nth 4 (org-heading-components)))) + (to (mp "MAIL_TO")) + (cc (mp "MAIL_CC")) + (bcc (mp "MAIL_BCC")) + (body (buffer-substring + (save-excursion (goto-char (point-min)) + (forward-line 1) + (when (looking-at "[ \t]*:PROPERTIES:") + (re-search-forward ":END:" nil) + (forward-char)) + (point)) + (point-max)))) + (org-mime-compose body (or fmt 'org) file to subject + `((cc . ,cc) (bcc . ,bcc))))))) + +(defun org-mime-send-buffer (&optional fmt) + (run-hooks 'org-mime-send-buffer-hook) + (let* ((region-p (org-region-active-p)) + (subject (org-export-grab-title-from-buffer)) + (file (buffer-file-name (current-buffer))) + (body-start (or (and region-p (region-beginning)) + (save-excursion (goto-char (point-min))))) + (body-end (or (and region-p (region-end)) (point-max))) + (temp-body-file (make-temp-file "org-mime-export")) + (body (buffer-substring body-start body-end))) + (org-mime-compose body (or fmt 'org) file nil subject))) + +(defun org-mime-compose (body fmt file &optional to subject headers) + (require 'message) + (message-mail to subject headers nil) + (message-goto-body) + (flet ((bhook (body fmt) + (let ((hook (intern (concat "org-mime-pre-" + (symbol-name fmt) + "-hook")))) + (if (> (eval `(length ,hook)) 0) + (with-temp-buffer + (insert body) + (goto-char (point-min)) + (eval `(run-hooks ',hook)) + (buffer-string)) + body)))) + (let ((fmt (if (symbolp fmt) fmt (intern fmt)))) + (cond + ((eq fmt 'org) + (insert (org-export-string (org-babel-trim (bhook body 'org)) 'org))) + ((eq fmt 'ascii) + (insert (org-export-string + (concat "#+Title:\n" (bhook body 'ascii)) 'ascii))) + ((or (eq fmt 'html) (eq fmt 'html-ascii)) + (let* ((org-link-file-path-type 'absolute) + ;; we probably don't want to export a huge style file + (org-export-htmlize-output-type 'inline-css) + (html-and-images (org-mime-replace-images + (org-export-string + (bhook body 'html) + 'html (file-name-nondirectory file)) + file)) + (images (cdr html-and-images)) + (html (org-mime-apply-html-hook (car html-and-images)))) + (insert (org-mime-multipart + (org-export-string + (org-babel-trim + (bhook body (if (eq fmt 'html) 'org 'ascii))) + (if (eq fmt 'html) 'org 'ascii)) + html) + (mapconcat 'identity images "\n")))))))) + +(defun org-mime-org-buffer-htmlize () + "Create an email buffer containing the current org-mode file + exported to html and encoded in both html and in org formats as + mime alternatives." + (interactive) + (org-mime-send-buffer 'html)) + +(defun org-mime-subtree () + "Create an email buffer containing the current org-mode subtree + exported to a org format or to the format specified by the + MAIL_FMT property of the subtree." + (interactive) + (org-mime-send-subtree + (or (org-entry-get nil "MAIL_FMT" org-mime-use-property-inheritance) 'org))) + +(provide 'org-mime) diff --git a/contrib/lisp/org-mtags.el b/contrib/lisp/org-mtags.el new file mode 100644 index 0000000..8ea5fa9 --- /dev/null +++ b/contrib/lisp/org-mtags.el @@ -0,0 +1,257 @@ +;;; org-mtags.el --- Muse-like tags in Org-mode + +;; Copyright (C) 2008-2012 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <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: +;; +;; This modules implements some of the formatting tags available in +;; Emacs Muse. This is not a way if adding new functionality, but just +;; a different way to write some formatting directives. The advantage is +;; that files written in this way can be read by Muse reasonably well, +;; and that this provides an alternative way of writing formatting +;; directives in Org, a way that some might find more pleasant to type +;; and look at that the Org's #+BEGIN..#+END notation. + +;; The goal of this development is to make it easier for people to +;; move between both worlds as they see fit for different tasks. + +;; The following muse tags will be translated during export into their +;; native Org equivalents: +;; +;; <br> +;; Needs to be at the end of a line. Will be translated to "\\". +;; +;; <example switches="-n -r"> +;; Needs to be on a line by itself, similarly the </example> tag. +;; Will be translated into Org's #+BEGIN_EXAMPLE construct. +;; +;; <quote> +;; Needs to be on a line by itself, similarly the </quote> tag. +;; Will be translated into Org's #+BEGIN_QUOTE construct. +;; +;; <comment> +;; Needs to be on a line by itself, similarly the </comment> tag. +;; Will be translated into Org's #+BEGIN_COMMENT construct. +;; +;; <verse> +;; Needs to be on a line by itself, similarly the </verse> tag. +;; Will be translated into Org's #+BEGIN_VERSE construct. +;; +;; <contents> +;; This gets translated into "[TABLE-OF-CONTENTS]". It will not +;; trigger the production of a table of contents - that is done +;; in Org with the "#+OPTIONS: toc:t" setting. But it will define +;; the location where the TOC will be placed. +;; +;; <literal style="STYLE"> ;; only latex, html, and docbook supported +;; in Org. +;; Needs to be on a line by itself, similarly the </literal> tag. +;; +;; <src lang="LANG" switches="-n -r"> +;; Needs to be on a line by itself, similarly the </src> tag. +;; Will be translated into Org's BEGIN_SRC construct. +;; +;; <include file="FILE" markup="MARKUP" lang="LANG" +;; prefix="str" prefix1="str" switches="-n -r"> +;; Needs to be on a line by itself. +;; Will be translated into Org's #+INCLUDE construct. +;; +;; The lisp/perl/ruby/python tags can be implemented using the +;; `org-eval.el' module, which see. + +(require 'org) + +;;; Customization + +(defgroup org-mtags nil + "Options concerning Muse tags in Org mode." + :tag "Org Muse Tags" + :group 'org) + +(defface org-mtags ; similar to shadow + (org-compatible-face 'shadow + '((((class color grayscale) (min-colors 88) (background light)) + (:foreground "grey50")) + (((class color grayscale) (min-colors 88) (background dark)) + (:foreground "grey70")) + (((class color) (min-colors 8) (background light)) + (:foreground "green")) + (((class color) (min-colors 8) (background dark)) + (:foreground "yellow")))) + "Face for Muse-like tags in Org." + :group 'org-mtags + :group 'org-faces) + +(defcustom org-mtags-prefer-muse-templates t + "Non-nil means prefere Muse tags for structure elements. +This is relevane when expanding the templates defined in the variable +`org-structure-templates'." + :group 'org-mtags + :type 'boolean) + +(defconst org-mtags-supported-tags + '("example" "quote" "comment" "verse" "contents" "literal" "src" "include") + "The tags that are supported by org-mtags.el for conversion. +In addition to this list, the <br> tag is supported as well.") + +(defconst org-mtags-fontification-re + (concat + "^[ \t]*</?\\(" + (mapconcat 'identity org-mtags-supported-tags "\\|") + "\\)\\>[^>]*>\\|<br>[ \t]*$") + "Regular expression used for fontifying muse tags.") + +(defun org-mtags-replace () + "Replace Muse-like tags with the appropriate Org constructs. +The is done in the entire buffer." + (interactive) ;; FIXME + (let ((re (concat "^[ \t]*\\(</?\\(" + (mapconcat 'identity org-mtags-supported-tags "\\|") + "\\)\\>\\)")) + info tag rpl style markup lang file prefix prefix1 switches) + ;; First, do the <br> tag + (goto-char (point-min)) + (while (re-search-forward "<br>[ \t]*$" nil t) + (replace-match "\\\\" t t)) + ;; Now, all the other tags + (goto-char (point-min)) + (while (re-search-forward re nil t) + (goto-char (match-beginning 1)) + (setq info (org-mtags-get-tag-and-attributes)) + (if (not info) + (end-of-line 1) + (setq tag (plist-get info :tag)) + (cond + ((equal tag "contents") + (setq rpl "[TABLE-OF-CONTENTS]") + ;; FIXME: also trigger TOC in options-plist????? + ) + ((member tag '("quote" "comment" "verse")) + (if (plist-get info :closing) + (setq rpl (format "#+END_%s" (upcase tag))) + (setq rpl (format "#+BEGIN_%s" (upcase tag))))) + ((equal tag "literal") + (setq style (plist-get info :style)) + (and style (setq style (downcase style))) + (if (plist-get info :closing) + (setq rpl (cond + ((member style '("latex")) + "#+END_LaTeX") + ((member style '("html")) + "#+END_HTML") + ((member style '("docbook")) + "#+END_DOCBOOK") + ((member style '("ascii")) + "#+END_ASCII"))) + (setq rpl (cond + ((member style '("latex")) + "#+BEGIN_LaTeX") + ((member style '("html")) + "#+BEGIN_HTML") + ((member style '("ascii")) + "#+BEGIN_ASCII"))))) + ((equal tag "example") + (if (plist-get info :closing) + (setq rpl "#+END_EXAMPLE") + (setq rpl "#+BEGIN_EXAMPLE") + (when (setq switches (plist-get info :switches)) + (setq rpl (concat rpl " " switches))))) + ((equal tag "src") + (if (plist-get info :closing) + (setq rpl "#+END_SRC") + (setq rpl "#+BEGIN_SRC") + (when (setq lang (plist-get info :lang)) + (setq rpl (concat rpl " " lang)) + (when (setq switches (plist-get info :switches)) + (setq rpl (concat rpl " " switches)))))) + ((equal tag "include") + (setq file (plist-get info :file) + markup (downcase (plist-get info :markup)) + lang (plist-get info :lang) + prefix (plist-get info :prefix) + prefix1 (plist-get info :prefix1) + switches (plist-get info :switches)) + (setq rpl "#+INCLUDE") + (setq rpl (concat rpl " " (prin1-to-string file))) + (when markup + (setq rpl (concat rpl " " markup)) + (when (and (equal markup "src") lang) + (setq rpl (concat rpl " " lang)))) + (when prefix + (setq rpl (concat rpl " :prefix " (prin1-to-string prefix)))) + (when prefix1 + (setq rpl (concat rpl " :prefix1 " (prin1-to-string prefix1)))) + (when switches + (setq rpl (concat rpl " " switches))))) + (when rpl + (goto-char (plist-get info :match-beginning)) + (delete-region (point-at-bol) (plist-get info :match-end)) + (insert rpl)))))) + +(defun org-mtags-get-tag-and-attributes () + "Parse a Muse-like tag at point ant rturn the information about it. +The return value is a property list which contains all the attributes +with string values. In addition, it reutnrs the following properties: + +:tag The tag as a string. +:match-beginning The beginning of the match, just before \"<\". +:match-end The end of the match, just after \">\". +:closing t when the tag starts with \"</\"." + (when (looking-at "<\\(/\\)?\\([a-zA-Z]+\\>\\)\\([^>]*\\)>") + (let ((start 0) + tag rest prop attributes endp val) + (setq tag (org-match-string-no-properties 2) + endp (match-end 1) + rest (and (match-end 3) + (org-match-string-no-properties 3)) + attributes (list :tag tag + :match-beginning (match-beginning 0) + :match-end (match-end 0) + :closing endp)) + (when rest + (while (string-match "\\([a-zA-Z]+\\)=\\([^ \t\n>]+\\|\"[^>]+\"\\)" + rest start) + (setq start (match-end 0) + prop (org-match-string-no-properties 1 rest) + val (org-remove-double-quotes + (org-match-string-no-properties 2 rest))) + (setq attributes (plist-put attributes + (intern (concat ":" prop)) val)))) + attributes))) + +(defun org-mtags-fontify-tags (limit) + "Fontify the muse-like tags." + (while (re-search-forward org-mtags-fontification-re limit t) + (add-text-properties (match-beginning 0) (match-end 0) + '(face org-mtags font-lock-multiline t + font-lock-fontified t)))) + +(add-hook 'org-export-preprocess-hook 'org-mtags-replace) +(add-hook 'org-font-lock-hook 'org-mtags-fontify-tags) + +(provide 'org-mtags) + +;;; org-mtags.el ends here diff --git a/contrib/lisp/org-notify.el b/contrib/lisp/org-notify.el new file mode 100644 index 0000000..9ddf150 --- /dev/null +++ b/contrib/lisp/org-notify.el @@ -0,0 +1,377 @@ +;;; org-notify.el --- Notifications for Org-mode + +;; Copyright (C) 2012 Free Software Foundation, Inc. + +;; Author: Peter Münster <pmrb@free.fr> +;; Keywords: notification, todo-list, alarm, reminder, pop-up + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Get notifications, when there is something to do. +;; Sometimes, you need a reminder a few days before a deadline, e.g. to buy a +;; present for a birthday, and then another notification one hour before to +;; have enough time to choose the right clothes. +;; For other events, e.g. rolling the dustbin to the roadside once per week, +;; you probably need another kind of notification strategy. +;; This package tries to satisfy the various needs. + +;; In order to activate this package, you must add the following code +;; into your .emacs: +;; +;; (require 'org-notify) +;; (org-notify-start) + +;; Example setup: +;; (org-notify-add 'appt +;; '(:time "-1s" :period "20s" :duration 10 +;; :actions (-message -ding)) +;; '(:time "15m" :period "2m" :duration 100 +;; :actions -notify) +;; '(:time "2h" :period "5m" :actions -message) +;; '(:time "3d" :actions -email)) +;; This means for todo-items with `notify' property set to `appt': 3 days +;; before deadline, send a reminder-email, 2 hours before deadline, start to +;; send messages every 5 minutes, then 15 minutes before deadline, start to +;; pop up notification windows every 2 minutes. The timeout of the window is +;; set to 100 seconds. Finally, when deadline is overdue, send messages and +;; make noise." + +;; Take also a look at the function `org-notify-add'. + +;;; Code: + +(eval-when-compile (require 'cl)) +(require 'org-element) + +(declare-function appt-delete-window "appt" ()) +(declare-function notifications-notify "notifications" (&rest prms)) +(declare-function article-lapsed-string "gnus-art" (t &optional ms)) + +(defgroup org-notify nil + "Options for Org-mode notifications." + :tag "Org Notify" + :group 'org) + +(defcustom org-notify-audible t + "Non-nil means beep to indicate notification." + :type 'boolean + :group 'org-notify) + +(defconst org-notify-actions + '("show" "show" "done" "done" "hour" "one hour later" "day" "one day later" + "week" "one week later") + "Possible actions for call-back functions.") + +(defconst org-notify-window-buffer-name "*org-notify-%s*" + "Buffer-name for the `org-notify-action-window' function.") + +(defvar org-notify-map nil + "Mapping between names and parameter lists.") + +(defvar org-notify-timer nil + "Timer of the notification daemon.") + +(defvar org-notify-parse-file nil + "Index of current file, that `org-element-parse-buffer' is parsing.") + +(defvar org-notify-on-action-map nil + "Mapping between on-action identifiers and parameter lists.") + +(defun org-notify-string->seconds (str) + "Convert time string STR to number of seconds." + (when str + (let* ((conv `(("s" . 1) ("m" . 60) ("h" . ,(* 60 60)) + ("d" . ,(* 24 60 60)) ("w" . ,(* 7 24 60 60)) + ("M" . ,(* 30 24 60 60)))) + (letters (concat + (mapcar (lambda (x) (string-to-char (car x))) conv))) + (case-fold-search nil)) + (string-match (concat "\\(-?\\)\\([0-9]+\\)\\([" letters "]\\)") str) + (* (string-to-number (match-string 2 str)) + (cdr (assoc (match-string 3 str) conv)) + (if (= (length (match-string 1 str)) 1) -1 1))))) + +(defun org-notify-make-todo (heading &rest ignored) + "Create one todo item." + (macrolet ((get (k) `(plist-get list ,k)) + (pr (k v) `(setq result (plist-put result ,k ,v)))) + (let* ((list (nth 1 heading)) (notify (or (get :notify) "default")) + (deadline (get :deadline)) (heading (get :raw-value)) + result) + (when (and (eq (get :todo-type) 'todo) heading deadline) + (pr :heading heading) (pr :notify (intern notify)) + (pr :begin (get :begin)) + (pr :file (nth org-notify-parse-file (org-agenda-files 'unrestricted))) + (pr :timestamp deadline) (pr :uid (md5 (concat heading deadline))) + (pr :deadline (- (org-time-string-to-seconds deadline) + (org-float-time)))) + result))) + +(defun org-notify-todo-list () + "Create the todo-list for one org-agenda file." + (let* ((files (org-agenda-files 'unrestricted)) + (max (1- (length files)))) + (setq org-notify-parse-file + (if (or (not org-notify-parse-file) (>= org-notify-parse-file max)) + 0 + (1+ org-notify-parse-file))) + (save-excursion + (with-current-buffer (find-file-noselect + (nth org-notify-parse-file files)) + (org-element-map (org-element-parse-buffer 'headline) + 'headline 'org-notify-make-todo))))) + +(defun org-notify-maybe-too-late (diff period heading) + "Print waring message, when notified significantly later than defined by +PERIOD." + (if (> (/ diff period) 1.5) + (message "Warning: notification for \"%s\" behind schedule!" heading)) + t) + +(defun org-notify-process () + "Process the todo-list, and possibly notify user about upcoming or +forgotten tasks." + (macrolet ((prm (k) `(plist-get prms ,k)) (td (k) `(plist-get todo ,k))) + (dolist (todo (org-notify-todo-list)) + (let* ((deadline (td :deadline)) (heading (td :heading)) + (uid (td :uid)) (last-run-sym + (intern (concat ":last-run-" uid)))) + (dolist (prms (plist-get org-notify-map (td :notify))) + (when (< deadline (org-notify-string->seconds (prm :time))) + (let ((period (org-notify-string->seconds (prm :period))) + (last-run (prm last-run-sym)) (now (org-float-time)) + (actions (prm :actions)) diff plist) + (when (or (not last-run) + (and period (< period (setq diff (- now last-run))) + (org-notify-maybe-too-late diff period heading))) + (setq prms (plist-put prms last-run-sym now) + plist (append todo prms)) + (if (if (plist-member prms :audible) + (prm :audible) + org-notify-audible) + (ding)) + (unless (listp actions) + (setq actions (list actions))) + (dolist (action actions) + (funcall (if (fboundp action) action + (intern (concat "org-notify-action" + (symbol-name action)))) + plist)))) + (return))))))) + +(defun org-notify-add (name &rest params) + "Add a new notification type. The NAME can be used in Org-mode property +`notify'. If NAME is `default', the notification type applies for todo items +without the `notify' property. This file predefines such a default +notification type. + +Each element of PARAMS is a list with parameters for a given time +distance to the deadline. This distance must increase from one element to +the next. +List of possible parameters: + :time Time distance to deadline, when this type of notification shall + start. It's a string: an integral value (positive or negative) + followed by a unit (s, m, h, d, w, M). + :actions A function or a list of functions to be called to notify the + user. Instead of a function name, you can also supply a suffix + of one of the various predefined `org-notify-action-xxx' + functions. + :period Optional: can be used to repeat the actions periodically. Same + format as :time. + :duration Some actions use this parameter to specify the duration of the + notification. It's an integral number in seconds. + :audible Overwrite the value of `org-notify-audible' for this action. + +For the actions, you can use your own functions or some of the predefined +ones, whose names are prefixed with `org-notify-action-'." + (setq org-notify-map (plist-put org-notify-map name params))) + +(defun org-notify-start (&optional secs) + "Start the notification daemon. If SECS is positive, it's the +period in seconds for processing the notifications of one +org-agenda file, and if negative, notifications will be checked +only when emacs is idle for -SECS seconds. The default value for +SECS is 20." + (if org-notify-timer + (org-notify-stop)) + (setq secs (or secs 20) + org-notify-timer (if (< secs 0) + (run-with-idle-timer (* -1 secs) t + 'org-notify-process) + (run-with-timer secs secs 'org-notify-process)))) + +(defun org-notify-stop () + "Stop the notification daemon." + (when org-notify-timer + (cancel-timer org-notify-timer) + (setq org-notify-timer nil))) + +(defun org-notify-on-action (plist key) + "User wants to see action." + (let ((file (plist-get plist :file)) + (begin (plist-get plist :begin))) + (if (string-equal key "show") + (progn + (switch-to-buffer (find-file-noselect file)) + (org-with-wide-buffer + (goto-char begin) + (show-entry)) + (goto-char begin) + (search-forward "DEADLINE: <") + (if (display-graphic-p) + (x-focus-frame nil))) + (save-excursion + (with-current-buffer (find-file-noselect file) + (org-with-wide-buffer + (goto-char begin) + (search-forward "DEADLINE: <") + (cond + ((string-equal key "done") (org-todo)) + ((string-equal key "hour") (org-timestamp-change 60 'minute)) + ((string-equal key "day") (org-timestamp-up-day)) + ((string-equal key "week") (org-timestamp-change 7 'day))))))))) + +(defun org-notify-on-action-notify (id key) + "User wants to see action after mouse-click in notify window." + (org-notify-on-action (plist-get org-notify-on-action-map id) key) + (org-notify-on-close id nil)) + +(defun org-notify-on-action-button (button) + "User wants to see action after button activation." + (macrolet ((get (k) `(button-get button ,k))) + (org-notify-on-action (get 'plist) (get 'key)) + (org-notify-delete-window (get 'buffer)) + (cancel-timer (get 'timer)))) + +(defun org-notify-delete-window (buffer) + "Delete the notification window." + (require 'appt) + (let ((appt-buffer-name buffer) + (appt-audible nil)) + (appt-delete-window))) + +(defun org-notify-on-close (id reason) + "Notification window has been closed." + (setq org-notify-on-action-map (plist-put org-notify-on-action-map id nil))) + +(defun org-notify-action-message (plist) + "Print a message." + (message "TODO: \"%s\" at %s!" (plist-get plist :heading) + (plist-get plist :timestamp))) + +(defun org-notify-action-ding (plist) + "Make noise." + (let ((timer (run-with-timer 0 1 'ding))) + (run-with-timer (or (plist-get plist :duration) 3) nil + 'cancel-timer timer))) + +(defun org-notify-body-text (plist) + "Make human readable string for remaining time to deadline." + (require 'gnus-art) + (format "%s\n(%s)" + (replace-regexp-in-string + " in the future" "" + (article-lapsed-string + (time-add (current-time) + (seconds-to-time (plist-get plist :deadline))) 2)) + (plist-get plist :timestamp))) + +(defun org-notify-action-email (plist) + "Send email to user." + (compose-mail user-mail-address (concat "TODO: " (plist-get plist :heading))) + (insert (org-notify-body-text plist)) + (funcall send-mail-function) + (flet ((yes-or-no-p (prompt) t)) + (kill-buffer))) + +(defun org-notify-select-highest-window () + "Select the highest window on the frame, that is not is not an +org-notify window. Mostly copied from `appt-select-lowest-window'." + (let ((highest-window (selected-window)) + (bottom-edge (nth 3 (window-edges))) + next-bottom-edge) + (walk-windows (lambda (w) + (when (and + (not (string-match "^\\*org-notify-.*\\*$" + (buffer-name + (window-buffer w)))) + (> bottom-edge (setq next-bottom-edge + (nth 3 (window-edges w))))) + (setq bottom-edge next-bottom-edge + highest-window w))) 'nomini) + (select-window highest-window))) + +(defun org-notify-action-window (plist) + "Pop up a window, mostly copied from `appt-disp-window'." + (save-excursion + (macrolet ((get (k) `(plist-get plist ,k))) + (let ((this-window (selected-window)) + (buf (get-buffer-create + (format org-notify-window-buffer-name (get :uid))))) + (when (minibufferp) + (other-window 1) + (and (minibufferp) (display-multi-frame-p) (other-frame 1))) + (if (cdr (assq 'unsplittable (frame-parameters))) + (progn (set-buffer buf) (display-buffer buf)) + (unless (or (special-display-p (buffer-name buf)) + (same-window-p (buffer-name buf))) + (org-notify-select-highest-window) + (when (>= (window-height) (* 2 window-min-height)) + (select-window (split-window nil nil 'above)))) + (switch-to-buffer buf)) + (setq buffer-read-only nil buffer-undo-list t) + (erase-buffer) + (insert (format "TODO: %s, %s.\n" (get :heading) + (org-notify-body-text plist))) + (let ((timer (run-with-timer (or (get :duration) 10) nil + 'org-notify-delete-window buf))) + (dotimes (i (/ (length org-notify-actions) 2)) + (let ((key (nth (* i 2) org-notify-actions)) + (text (nth (1+ (* i 2)) org-notify-actions))) + (insert-button text 'action 'org-notify-on-action-button + 'key key 'buffer buf 'plist plist 'timer timer) + (insert " ")))) + (shrink-window-if-larger-than-buffer (get-buffer-window buf t)) + (set-buffer-modified-p nil) (setq buffer-read-only t) + (raise-frame (selected-frame)) (select-window this-window))))) + +(defun org-notify-action-notify (plist) + "Pop up a notification window." + (require 'notifications) + (let* ((duration (plist-get plist :duration)) + (id (notifications-notify + :title (plist-get plist :heading) + :body (org-notify-body-text plist) + :timeout (if duration (* duration 1000)) + :actions org-notify-actions + :on-action 'org-notify-on-action-notify))) + (setq org-notify-on-action-map + (plist-put org-notify-on-action-map id plist)))) + +(defun org-notify-action-notify/window (plist) + "For a graphics display, pop up a notification window, for a text +terminal an emacs window." + (if (display-graphic-p) + (org-notify-action-notify plist) + (org-notify-action-window plist))) + +;;; Provide a minimal default setup. +(org-notify-add 'default '(:time "1h" :actions -notify/window + :period "2m" :duration 60)) + +(provide 'org-notify) + +;;; org-notify.el ends here diff --git a/contrib/lisp/org-notmuch.el b/contrib/lisp/org-notmuch.el new file mode 100644 index 0000000..0affd71 --- /dev/null +++ b/contrib/lisp/org-notmuch.el @@ -0,0 +1,105 @@ +;;; org-notmuch.el --- Support for links to notmuch messages from within Org-mode + +;; Copyright (C) 2010-2012 Matthieu Lemerre + +;; Author: Matthieu Lemerre <racin@free.fr> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. + +;; This file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; This file implements links to notmuch messages and "searchs". A +;; search is a query to be performed by notmuch; it is the equivalent +;; to folders in other mail clients. Similarly, mails are refered to +;; by a query, so both a link can refer to several mails. + +;; Links have one the following form +;; notmuch:<search terms> +;; notmuch-search:<search terms>. + +;; The first form open the queries in notmuch-show mode, whereas the +;; second link open it in notmuch-search mode. Note that queries are +;; performed at the time the link is opened, and the result may be +;; different from whet the link was stored. + +;;; Code: + +(require 'org) + +;; Install the link type +(org-add-link-type "notmuch" 'org-notmuch-open) +(add-hook 'org-store-link-functions 'org-notmuch-store-link) + +(defun org-notmuch-store-link () + "Store a link to a notmuch search or message." + (when (eq major-mode 'notmuch-show-mode) + (let* ((message-id (notmuch-show-get-prop :id)) + (subject (notmuch-show-get-subject)) + (to (notmuch-show-get-to)) + (from (notmuch-show-get-from)) + desc link) + (org-store-link-props :type "notmuch" :from from :to to + :subject subject :message-id message-id) + (setq desc (org-email-link-description)) + (setq link (concat "notmuch:" "id:" message-id)) + (org-add-link-props :link link :description desc) + link))) + +(defun org-notmuch-open (path) + "Follow a notmuch message link specified by PATH." + (org-notmuch-follow-link path)) + +(defun org-notmuch-follow-link (search) + "Follow a notmuch link to SEARCH. + +Can link to more than one message, if so all matching messages are shown." + (require 'notmuch) + (notmuch-show (org-link-unescape search))) + + + + +(org-add-link-type "notmuch-search" 'org-notmuch-search-open) +(add-hook 'org-store-link-functions 'org-notmuch-search-store-link) + +(defun org-notmuch-search-store-link () + "Store a link to a notmuch search or message." + (when (eq major-mode 'notmuch-search-mode) + (let ((link (concat "notmuch-search:" + (org-link-escape notmuch-search-query-string))) + (desc (concat "Notmuch search: " notmuch-search-query-string))) + (org-store-link-props :type "notmuch-search" + :link link + :description desc) + link))) + +(defun org-notmuch-search-open (path) + "Follow a notmuch message link specified by PATH." + (message path) + (org-notmuch-search-follow-link path)) + +(defun org-notmuch-search-follow-link (search) + "Follow a notmuch link by displaying SEARCH in notmuch-search mode." + (require 'notmuch) + (notmuch-search (org-link-unescape search))) + +(provide 'org-notmuch) + +;;; org-notmuch.el ends here diff --git a/contrib/lisp/org-panel.el b/contrib/lisp/org-panel.el new file mode 100644 index 0000000..3ffdfaf --- /dev/null +++ b/contrib/lisp/org-panel.el @@ -0,0 +1,641 @@ +;;; org-panel.el --- Simple routines for us with bad memory +;; +;; Author: Lennart Borgman (lennart O borgman A gmail O com) +;; Created: Thu Nov 15 15:35:03 2007 +;; Version: 0.21 +;; Lxast-Updated: Wed Nov 21 03:06:03 2007 (3600 +0100) +;; URL: +;; Keywords: +;; Compatibility: +;; +;; Features that might be required by this library: +;; +;; `easymenu', `font-lock', `noutline', `org', `outline', `syntax', +;; `time-date'. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This defines a kind of control panel for `org-mode'. This control +;; panel should make it fast to move around and edit structure etc. +;; +;; To bring up the control panel type +;; +;; M-x orgpan-panel +;; +;; Type ? there for help. +;; +;; I suggest you add the following to your .emacs for quick access of +;; the panel: +;; +;; (eval-after-load 'org-mode +;; (define-key org-mode-map [(control ?c) ?p] 'orgpan-panel)) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Change log: +;; +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 2, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth +;; Floor, Boston, MA 02110-1301, USA. +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Code: + +(require 'org) +(require 'outline) + +;; Fix-me: this is for testing. A minor mode version interferes badly +;; with emulation minor modes. On the other hand, the other version +;; interferes badly with (interactive ...). +(defvar orgpan-minor-mode-version t) + +(defface orgpan-field + '((t (:inherit 'widget-field))) + "Face for fields." + :group 'winsize) +(defvar orgpan-field-face 'orgpan-field) + +(defface orgpan-active-field + '((t (:inherit 'highlight))) + "Face for fields." + :group 'winsize) +(defvar orgpan-active-field-face 'orgpan-active-field) + +(defface orgpan-spaceline + '((t (:height 0.2))) + "Face for spacing lines." + :group 'winsize) + +(defcustom orgpan-panel-buttons nil + "Panel style, if non-nil use buttons. +If there are buttons in the panel they are used to change the way +the arrow keys work. The panel looks something like this, with +the first button chosen: + + [Navigate] [Restructure] [TODO/Priority] + ---------- + up/down, left: Go to, right: Visibility + +The line below the buttons try to give a short hint about what +the arrow keys does. \(Personally I prefer the version without +buttons since I then do not have to remember which button is +active.)" + :type 'boolean + :group 'winsize) + +;; Fix-me: add org-mode-map +(defconst orgpan-org-mode-commands nil) +(defconst orgpan-org-commands + '( + orgpan-copy-subtree + orgpan-cut-subtree + orgpan-paste-subtree + undo + ;; + ;orgpan-occur + ;; + org-cycle + org-global-cycle + outline-up-heading + outline-next-visible-heading + outline-previous-visible-heading + outline-forward-same-level + outline-backward-same-level + org-todo + org-show-todo-tree + org-priority-up + org-priority-down + org-move-subtree-up + org-move-subtree-down + org-do-promote + org-do-demote + org-promote-subtree + org-demote-subtree)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Hook functions etc + +;;(defvar orgpan-this-panel-window nil) + +(defun orgpan-delete-panel () + "Remove the panel." + (interactive) + (when (buffer-live-p orgpan-panel-buffer) + (delete-windows-on orgpan-panel-buffer) + (kill-buffer orgpan-panel-buffer)) + (setq orgpan-panel-buffer nil) + (setq orgpan-panel-window nil) + (orgpan-panel-minor-mode 0) + (remove-hook 'post-command-hook 'orgpan-minor-post-command) + (remove-hook 'post-command-hook 'orgpan-mode-post-command) + ;;(remove-hook 'window-configuration-change-hook 'orgpan-window-config-change) + ) + +(defvar orgpan-last-command-was-from-panel nil) +(defun orgpan-mode-pre-command () + (setq orgpan-last-command-was-from-panel nil) + (condition-case err + (if (not (and (windowp orgpan-org-window) + (window-live-p orgpan-org-window))) + (progn + (setq this-command 'ignore) + (orgpan-delete-panel) + (message "The window belonging to the panel had disappeared, removed panel.")) + (let ((buf (window-buffer orgpan-org-window))) + (when (with-current-buffer buf + (derived-mode-p 'org-mode)) + (setq orgpan-last-org-buffer buf)) + ;; Fix me: add a list of those commands that are not + ;; meaningful from the panel (for example org-time-stamp) + (when (or (memq this-command orgpan-org-commands) + (memq this-command orgpan-org-mode-commands) + ;; For some reason not all org commands are found above: + (string= "org-" (substring (format "%s" this-command) 0 4))) + (if (not (with-current-buffer buf + (derived-mode-p 'org-mode))) + (progn + (if (buffer-live-p orgpan-org-buffer) + (set-window-buffer orgpan-org-window orgpan-org-buffer) + (message "Please use `l' or `b' to choose an org-mode buffer")) + (setq this-command 'ignore)) + (setq orgpan-org-buffer (window-buffer orgpan-org-window)) + (setq orgpan-last-command-was-from-panel t) + (select-window orgpan-org-window) + ;;(when (active-minibuffer-window + ;;(set-buffer orgpan-org-buffer) + )))) + (error (lwarn 't :warning "orgpan-pre: %S" err)))) + +(defun orgpan-mode-post-command () + (condition-case err + (progn + (unless (and (windowp orgpan-panel-window) + (window-live-p orgpan-panel-window) + (bufferp orgpan-panel-buffer) + (buffer-live-p orgpan-panel-buffer)) + ;;(orgpan-delete-panel) + ) + (when (and orgpan-last-command-was-from-panel + (windowp orgpan-panel-window) + (window-live-p orgpan-panel-window)) + (select-window orgpan-panel-window) + (when (derived-mode-p 'orgpan-mode) + (setq deactivate-mark t) + (when orgpan-panel-buttons + (unless (and orgpan-point + (= (point) orgpan-point)) + ;; Go backward so it is possible to click on a "button": + (orgpan-backward-field))))) + (setq orgpan-this-panel-window nil)) + (error (lwarn 't :warning "orgpan-post: %S" err)))) + +;; (defun orgpan-window-config-change () +;; "Check if any frame is displaying an orgpan panel. +;; If not remove `orgpan-mode-post-command' and this function from +;; the hooks." +;; (condition-case err +;; (unless (and ( +;; (let ((found-pan nil)) +;; (dolist (f (frame-list)) +;; (dolist (w (window-list f 'nomini)) +;; (with-current-buffer (window-buffer w) +;; (when (derived-mode-p 'orgpan-mode) +;; (setq found-pan t))))) +;; (unless found-pan +;; (remove-hook 'post-command-hook 'orgpan-mode-post-command) +;; (remove-hook 'window-configuration-change-hook 'orgpan-window-config-change))) +;; (error (lwarn 't :warning "Error in orgpan-config-change: %S" err)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Commands + +(defun orgpan-last-buffer () + "Open last org-mode buffer in panels org window." + (interactive) + (let ((buf (window-buffer orgpan-org-window)) + (last-buf orgpan-last-org-buffer)) + (when (with-current-buffer buf + (derived-mode-p 'org-mode)) + (setq orgpan-last-org-buffer buf)) + (when (eq last-buf buf) + (setq last-buf nil)) + (if (not last-buf) + (orgpan-switch-buffer) + (set-window-buffer orgpan-org-window last-buf)))) + +(defun orgpan-switch-buffer () + "Switch to next org-mode buffer in panels org window." + (interactive) + (let ((buf (window-buffer orgpan-org-window)) + (org-buffers nil)) + (with-current-buffer buf + (when (derived-mode-p 'org-mode) + (bury-buffer buf) + (setq orgpan-last-org-buffer buf))) + (setq org-buffers (delq nil (mapcar (lambda (buf) + (when (with-current-buffer buf + (derived-mode-p 'org-mode)) + buf)) + (buffer-list)))) + (setq org-buffers (delq buf org-buffers)) + (set-window-buffer orgpan-org-window (car org-buffers)) + (setq orgpan-org-buffer (car org-buffers)))) + +(defun orgpan-paste-subtree () + (interactive) + (if (y-or-n-p "Paste subtree here? ") + (org-paste-subtree) + (message "Nothing was pasted"))) + +(defun orgpan-cut-subtree () + (interactive) + (let ((heading (progn + (org-back-to-heading) + (buffer-substring (point) (line-end-position)) + ))) + (if (y-or-n-p (format "Do you want to cut the subtree\n%s\n? " heading)) + (org-cut-subtree) + (message "Nothing was cut")))) + +(defun orgpan-copy-subtree () + (interactive) + (let ((heading (progn + (org-back-to-heading) + (buffer-substring (point) (line-end-position)) + ))) + (if (y-or-n-p (format "Do you want to copy the subtree\n%s\n? " heading)) + (org-copy-subtree) + (message "Nothing was copied")))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Buttons + +(defvar orgpan-ovl-help nil) + +(defun orgpan-check-panel-mode () + (unless (derived-mode-p 'orgpan-mode) + (error "Not orgpan-mode in buffer: " major-mode))) + +(defun orgpan-display-bindings-help () + (orgpan-check-panel-mode) + (setq orgpan-point (point)) + (let* ((ovls (overlays-at (point))) + (ovl (car ovls)) + (help (when ovl (overlay-get ovl 'orgpan-explain)))) + (dolist (o (overlays-in (point-min) (point-max))) + (overlay-put o 'face orgpan-field-face)) + (overlay-put ovl 'face orgpan-active-field-face) + (overlay-put orgpan-ovl-help 'before-string help))) + +(defun orgpan-forward-field () + (interactive) + (orgpan-check-panel-mode) + (let ((pos (next-overlay-change (point)))) + (unless (overlays-at pos) + (setq pos (next-overlay-change pos))) + (when (= pos (point-max)) + (setq pos (point-min)) + (unless (overlays-at pos) + (setq pos (next-overlay-change pos)))) + (goto-char pos)) + (orgpan-display-bindings-help)) + +(defun orgpan-backward-field () + (interactive) + (orgpan-check-panel-mode) + (when (= (point) (point-min)) + (goto-char (point-max))) + (let ((pos (previous-overlay-change (point)))) + (unless (overlays-at pos) + (setq pos (previous-overlay-change pos))) + (goto-char pos)) + (orgpan-display-bindings-help)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Mode + +(defconst orgpan-mode-map + ;; Fix-me: clean up here! + ;; Fix-me: viper support + (let ((map (make-sparse-keymap))) + (define-key map [?q] 'orgpan-delete-panel) + (define-key map [??] 'orgpan-help) + ;; Copying etc + (define-key map [?c] 'orgpan-copy-subtree) + (define-key map [?x] 'orgpan-cut-subtree) + (define-key map [?p] 'orgpan-paste-subtree) + (define-key map [?z] 'undo) + ;; Buffers: + (define-key map [?b] 'orgpan-switch-buffer) + (define-key map [?l] 'orgpan-last-buffer) + ;; Some keys for moving between headings. Emacs keys for next/prev + ;; line seems ok: + (define-key map [(control ?p)] 'outline-previous-visible-heading) + (define-key map [(control ?n)] 'outline-next-visible-heading) + (define-key map [(shift control ?p)] 'outline-backward-same-level) + (define-key map [(shift control ?n)] 'outline-forward-same-level) + ;; A mnemunic for up: + (define-key map [(control ?u)] 'outline-up-heading) + ;; Search sparse tree: + ;; + ;; Fix-me: Search does not work, some problem with + ;; interactive. Probably have to turn the whole thing around and + ;; always be in the org buffer, but with a minor mode running + ;; there. + ;; + ;;(define-key map [?s] 'org-sparse-tree) + (define-key map [?s] 'orgpan-occur) + ;; Same as in org-mode: + ;;(define-key map [(control ?c)(control ?v)] 'org-show-todo-tree) + ;; Fix-me: This leads to strange problems: + ;;(define-key map [t] 'ignore) + map)) + +(defun orgpan-occur () + "Replacement for `org-occur'. +Technical reasons." + (interactive) + (let ((rgx (read-from-minibuffer "my mini Regexp: "))) + (setq orgpan-last-command-was-from-panel t) + (select-window orgpan-org-window) + (org-occur rgx))) + +(defvar orgpan-panel-window nil + "The window showing `orgpan-panel-buffer'.") + +(defvar orgpan-panel-buffer nil + "The panel buffer. +There can be only one such buffer at any time.") + +(defvar orgpan-org-window nil) +;;(make-variable-buffer-local 'orgpan-org-window) + +;; Fix-me: used? +(defvar orgpan-org-buffer nil) +;;(make-variable-buffer-local 'orgpan-org-buffer) + +(defvar orgpan-last-org-buffer nil) +;;(make-variable-buffer-local 'orgpan-last-org-buffer) + +(defvar orgpan-point nil) +;;(make-variable-buffer-local 'orgpan-point) + +(defun orgpan-avoid-viper-in-buffer () + ;; Fix-me: This is ugly. However see `this-major-mode-requires-vi-state': + (set (make-local-variable 'viper-emacs-state-mode-list) '(orgpan-mode)) + (set (make-local-variable 'viper-new-major-mode-buffer-list) nil) + (local-set-key [?\ ] 'ignore)) + +(define-derived-mode orgpan-mode nil "Org-Panel" + "Mode for org-simple.el control panel." + (setq buffer-read-only t) + (unless orgpan-minor-mode-version + (add-hook 'pre-command-hook 'orgpan-mode-pre-command nil t) + (add-hook 'post-command-hook 'orgpan-mode-post-command t)) + (orgpan-avoid-viper-in-buffer) + (setq cursor-type nil)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Panel layout + +(defun orgpan-insert-field (text keymap explain) + (insert text) + (let* ((end (point)) + (len (length text)) + (beg (- end len)) + (ovl (make-overlay beg end))) + (overlay-put ovl 'face orgpan-field-face) + (overlay-put ovl 'keymap keymap) + (overlay-put ovl 'orgpan-explain explain))) + +(defconst orgpan-with-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map org-mode-map) + ;; Users are used to tabbing between fields: + (define-key map [(tab)] 'orgpan-forward-field) + (define-key map [(shift tab)] 'orgpan-backward-field) + ;; Now we must use something else for visibility (first does not work if Viper): + (define-key map [(meta tab)] 'org-cycle) + (define-key map [(control meta tab)] 'org-global-cycle) + map)) + +(defconst orgpan-without-keymap + (let ((map (make-sparse-keymap))) + (set-keymap-parent map org-mode-map) + ;; Visibility (those are in org-mode-map): + ;;(define-key map [tab] 'org-cycle) + ;;(define-key map [(shift tab)] 'org-global-cycle) + ;; Navigate: + (define-key map [left] 'outline-up-heading) + (define-key map [right] 'org-cycle) + (define-key map [up] 'outline-previous-visible-heading) + (define-key map [down] 'outline-next-visible-heading) + (define-key map [(shift down)] 'outline-forward-same-level) + (define-key map [(shift up)] 'outline-backward-same-level) + ;; Restructure: + (define-key map [(control up)] 'org-move-subtree-up) + (define-key map [(control down)] 'org-move-subtree-down) + (define-key map [(control left)] 'org-do-promote) + (define-key map [(control right)] 'org-do-demote) + (define-key map [(control shift left)] 'org-promote-subtree) + (define-key map [(control shift right)] 'org-demote-subtree) + ;; Todo etc + (define-key map [?+] 'org-priority-up) + (define-key map [?-] 'org-priority-down) + (define-key map [?t] 'org-todo) + map)) + +(defun orgpan-make-panel-without-buttons (buf) + (with-current-buffer buf + (insert (propertize "Org Panel" 'face 'orgpan-active-field)) + (insert " ? for help, q quit\n") + (insert (propertize "arrows" 'face 'font-lock-keyword-face) + ": Go to, " + (propertize "C-arrows" 'face 'font-lock-keyword-face) + ": Edit tree\n" + (propertize "cxpz" 'face 'font-lock-keyword-face) + ": copy cut paste undo, " + (propertize "tT+-" 'face 'font-lock-keyword-face) + ": todo priority, " + (propertize "s" 'face 'font-lock-keyword-face) + " search" + ) + (set-keymap-parent orgpan-mode-map orgpan-without-keymap) + )) + +(defun orgpan-make-panel-with-buttons (buf) + (with-current-buffer buf + (let* ((base-map (make-sparse-keymap)) + (space-line (propertize "\n\n" 'face 'orgpan-spaceline)) + (arrow-face 'font-lock-keyword-face) + (L (propertize "left" 'face arrow-face)) + (R (propertize "right" 'face arrow-face)) + (U (propertize "up" 'face arrow-face)) + (D (propertize "down" 'face arrow-face))) + ;;(message D)(sit-for 2) + (define-key base-map [left] 'ignore) + (define-key base-map [right] 'ignore) + (define-key base-map [up] 'ignore) + (define-key base-map [down] 'ignore) + (define-key base-map [?q] 'delete-window) + (define-key base-map [??] 'orgpan-help) + ;; Navigating + (let ((map (copy-keymap base-map))) + (define-key map [left] 'outline-up-heading) + (define-key map [right] 'org-cycle) + (define-key map [up] 'outline-previous-visible-heading) + (define-key map [down] 'outline-next-visible-heading) + (define-key map [(shift down)] 'outline-forward-same-level) + (define-key map [(shift up)] 'outline-backward-same-level) + (orgpan-insert-field "Navigate" map (concat U "/" D ", " L ": Go to, " R ": Visibility"))) + (insert " ") + (let ((map (copy-keymap base-map))) + (define-key map [up] 'org-move-subtree-up) + (define-key map [down] 'org-move-subtree-down) + (define-key map [left] 'org-do-promote) + (define-key map [right] 'org-do-demote) + (define-key map [(shift left)] 'org-promote-subtree) + (define-key map [(shift right)] 'org-demote-subtree) + (orgpan-insert-field + "Restructure" map + (concat U "/" D ": " + (propertize "Move" 'face 'font-lock-warning-face) + ", " L "/" R ": " + (propertize "Level (w S: Subtree Level)" 'face 'font-lock-warning-face)))) + (insert " ") + (let ((map (copy-keymap base-map))) + (define-key map [up] 'org-priority-up) + (define-key map [down] 'org-priority-down) + (define-key map [right] 'org-todo) + (orgpan-insert-field "TODO/priority" map + (concat R ": TODO, " U "/" D ": Priority"))) + ) + (insert " ? for help, q quit\n") + (orgpan-display-bindings-help) + (setq orgpan-ovl-help (make-overlay (point) (point))) + )) + +(defun orgpan-make-panel-buffer () + "Make the panel buffer." + (let* ((buf-name "*Org Panel*")) + (when orgpan-panel-buffer (kill-buffer orgpan-panel-buffer)) + (setq orgpan-panel-buffer (get-buffer-create buf-name)) + (if orgpan-panel-buttons + (orgpan-make-panel-with-buttons orgpan-panel-buffer) + (orgpan-make-panel-without-buttons orgpan-panel-buffer)) + (with-current-buffer orgpan-panel-buffer + (orgpan-mode) + (goto-char (point-min))) + orgpan-panel-buffer)) + +(defun orgpan-help () + (interactive) + (set-keymap-parent orgpan-with-keymap nil) + (set-keymap-parent orgpan-without-keymap nil) + (describe-function 'orgpan-panel) + (set-keymap-parent orgpan-with-keymap org-mode-map) + (set-keymap-parent orgpan-without-keymap org-mode-map) + (message "Use 'l' to remove help window") + ) + +(defun orgpan-panel () + "Create a control panel for current `org-mode' buffer. +The control panel may be used to quickly move around and change +the headings. The idea is that when you want to to a lot of this +kind of editing you should be able to do that with few +keystrokes (and without having to remember the complicated +keystrokes). A typical situation when this perhaps can be useful +is when you are looking at your notes file \(usually ~/.notes, +see `remember-data-file') where you have saved quick notes with +`remember'. + +The keys below are defined in the panel. Note that the commands +are carried out in the `org-mode' buffer that belongs to the +panel. + +\\{orgpan-mode-map} + +In addition to the keys above most of the keys in `org-mode' can +also be used from the panel. + +Note: There are two forms of the control panel, one with buttons +and one without. The default is without, see +`orgpan-panel-buttons'. If buttons are used choosing a different +button changes the binding of the arrow keys." + (interactive) + (unless (derived-mode-p 'org-mode) + (error "Buffer is not in org-mode")) + (orgpan-delete-panel) + (unless orgpan-org-mode-commands + (map-keymap (lambda (ev def) + (when (and def + (symbolp def) + (fboundp def)) + (setq orgpan-org-mode-commands + (cons def orgpan-org-mode-commands)))) + org-mode-map)) + ;;(org-back-to-heading) + ;;(remove-hook 'window-configuration-change-hook 'orgpan-window-config-change) + (split-window) + (set-window-buffer (selected-window) (orgpan-make-panel-buffer)) + (setq orgpan-panel-window (selected-window)) + ;;(set-window-dedicated-p (selected-window) t) + (fit-window-to-buffer nil nil 3) + (setq orgpan-org-window (next-window)) + ;; The minor mode version starts here: + (when orgpan-minor-mode-version + (select-window orgpan-org-window) + (orgpan-panel-minor-mode 1) + (add-hook 'post-command-hook 'orgpan-minor-post-command t))) + +(defun orgpan-minor-post-command () + (unless (and + ;; Check org window and buffer + (windowp orgpan-org-window) + (window-live-p orgpan-org-window) + (eq orgpan-org-window (selected-window)) + (derived-mode-p 'org-mode) + ;; Check panel window and buffer + (windowp orgpan-panel-window) + (window-live-p orgpan-panel-window) + (bufferp orgpan-panel-buffer) + (buffer-live-p orgpan-panel-buffer) + (eq (window-buffer orgpan-panel-window) orgpan-panel-buffer) + ;; Check minor mode + orgpan-panel-minor-mode) + (orgpan-delete-panel))) + +(define-minor-mode orgpan-panel-minor-mode + "Minor mode used in `org-mode' buffer when showing panel." + :keymap orgpan-mode-map + :lighter " PANEL" + :group 'orgpan + ) + + +(provide 'org-panel) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; org-panel.el ends here diff --git a/contrib/lisp/org-registry.el b/contrib/lisp/org-registry.el new file mode 100644 index 0000000..c1a1c6c --- /dev/null +++ b/contrib/lisp/org-registry.el @@ -0,0 +1,271 @@ +;;; org-registry.el --- a registry for Org links +;; +;; Copyright 2007-2012 Bastien Guerry +;; +;; Emacs Lisp Archive Entry +;; Filename: org-registry.el +;; Version: 0.1a +;; Author: Bastien Guerry <bzg AT gnu DOT org> +;; Maintainer: Bastien Guerry <bzg AT gnu DOT org> +;; Keywords: org, wp, registry +;; Description: Shows Org files where the current buffer is linked +;; URL: http://www.cognition.ens.fr/~guerry/u/org-registry.el +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: +;; +;; This library add a registry to your Org setup. +;; +;; Org files are full of links inserted with `org-store-link'. This links +;; point to e-mail, webpages, files, dirs, info pages, man pages, etc. +;; Actually, they come from potentially *everywhere* since Org lets you +;; define your own storing/following functions. +;; +;; So, what if you are on a e-mail, webpage or whatever and want to know if +;; this buffer has already been linked to somewhere in your agenda files? +;; +;; This is were org-registry comes in handy. +;; +;; M-x org-registry-show will tell you the name of the file +;; C-u M-x org-registry-show will directly jump to the file +;; +;; In case there are several files where the link lives in: +;; +;; M-x org-registry-show will display them in a new window +;; C-u M-x org-registry-show will prompt for a file to visit +;; +;; Add this to your Org configuration: +;; +;; (require 'org-registry) +;; (org-registry-initialize) +;; +;; If you want to update the registry with newly inserted links in the +;; current buffer: M-x org-registry-update +;; +;; If you want this job to be done each time you save an Org buffer, +;; hook 'org-registry-update to the local 'after-save-hook in org-mode: +;; +;; (org-registry-insinuate) + +;;; Code: + +(eval-when-compile + (require 'cl)) + +(defgroup org-registry nil + "A registry for Org." + :group 'org) + +(defcustom org-registry-file + (concat (getenv "HOME") "/.org-registry.el") + "The Org registry file." + :group 'org-registry + :type 'file) + +(defcustom org-registry-find-file 'find-file-other-window + "How to find visit files." + :type 'function + :group 'org-registry) + +(defvar org-registry-alist nil + "An alist containing the Org registry.") + +;;;###autoload +(defun org-registry-show (&optional visit) + "Show Org files where there are links pointing to the current +buffer." + (interactive "P") + (org-registry-initialize) + (let* ((blink (or (org-remember-annotation) "")) + (link (when (string-match org-bracket-link-regexp blink) + (match-string-no-properties 1 blink))) + (desc (or (and (string-match org-bracket-link-regexp blink) + (match-string-no-properties 3 blink)) "No description")) + (files (org-registry-assoc-all link)) + file point selection tmphist) + (cond ((and files visit) + ;; result(s) to visit + (cond ((< 1 (length files)) + ;; more than one result + (setq tmphist (mapcar (lambda(entry) + (format "%s (%d) [%s]" + (nth 3 entry) ; file + (nth 2 entry) ; point + (nth 1 entry))) files)) + (setq selection (completing-read "File: " tmphist + nil t nil 'tmphist)) + (string-match "\\(.+\\) (\\([0-9]+\\))" selection) + (setq file (match-string 1 selection)) + (setq point (string-to-number (match-string 2 selection)))) + ((eq 1 (length files)) + ;; just one result + (setq file (nth 3 (car files))) + (setq point (nth 2 (car files))))) + ;; visit the (selected) file + (funcall org-registry-find-file file) + (goto-char point) + (unless (org-before-first-heading-p) + (org-show-context))) + ((and files (not visit)) + ;; result(s) to display + (cond ((eq 1 (length files)) + ;; show one file + (message "Link in file %s (%d) [%s]" + (nth 3 (car files)) + (nth 2 (car files)) + (nth 1 (car files)))) + (t (org-registry-display-files files link)))) + (t (message "No link to this in org-agenda-files"))))) + +(defun org-registry-display-files (files link) + "Display files in a separate window." + (switch-to-buffer-other-window + (get-buffer-create " *Org registry info*")) + (erase-buffer) + (insert (format "Files pointing to %s:\n\n" link)) + (let (file) + (while (setq file (pop files)) + (insert (format "%s (%d) [%s]\n" (nth 3 file) + (nth 2 file) (nth 1 file))))) + (shrink-window-if-larger-than-buffer) + (other-window 1)) + +(defun org-registry-assoc-all (link &optional registry) + "Return all associated entries of LINK in the registry." + (org-registry-find-all + (lambda (entry) (string= link (car entry))) + registry)) + +(defun org-registry-find-all (test &optional registry) + "Return all entries satisfying `test' in the registry." + (delq nil + (mapcar + (lambda (x) (and (funcall test x) x)) + (or registry org-registry-alist)))) + +;;;###autoload +(defun org-registry-visit () + "If an Org file contains a link to the current location, visit +this file." + (interactive) + (org-registry-show t)) + +;;;###autoload +(defun org-registry-initialize (&optional from-scratch) + "Initialize `org-registry-alist'. +If FROM-SCRATCH is non-nil or the registry does not exist yet, +create a new registry from scratch and eval it. If the registry +exists, eval `org-registry-file' and make it the new value for +`org-registry-alist'." + (interactive "P") + (if (or from-scratch (not (file-exists-p org-registry-file))) + ;; create a new registry + (let ((files org-agenda-files) file) + (while (setq file (pop files)) + (setq file (expand-file-name file)) + (mapc (lambda (entry) + (add-to-list 'org-registry-alist entry)) + (org-registry-get-entries file))) + (when from-scratch + (org-registry-create org-registry-alist))) + ;; eval the registry file + (with-temp-buffer + (insert-file-contents org-registry-file) + (eval-buffer)))) + +;;;###autoload +(defun org-registry-insinuate () + "Call `org-registry-update' after saving in Org-mode. +Use with caution. This could slow down things a bit." + (interactive) + (add-hook 'org-mode-hook + (lambda() (add-hook 'after-save-hook + 'org-registry-update t t)))) + +(defun org-registry-get-entries (file) + "List Org links in FILE that will be put in the registry." + (let (bufstr result) + (with-temp-buffer + (insert-file-contents file) + (goto-char (point-min)) + (while (re-search-forward org-angle-link-re nil t) + (let* ((point (match-beginning 0)) + (link (match-string-no-properties 0)) + (desc (match-string-no-properties 0))) + (add-to-list 'result (list link desc point file)))) + (goto-char (point-min)) + (while (re-search-forward org-bracket-link-regexp nil t) + (let* ((point (match-beginning 0)) + (link (match-string-no-properties 1)) + (desc (or (match-string-no-properties 3) "No description"))) + (add-to-list 'result (list link desc point file))))) + ;; return the list of new entries + result)) + +;;;###autoload +(defun org-registry-update () + "Update the registry for the current Org file." + (interactive) + (unless (eq major-mode 'org-mode) (error "Not in org-mode")) + (let* ((from-file (expand-file-name (buffer-file-name))) + (new-entries (org-registry-get-entries from-file))) + (with-temp-buffer + (unless (file-exists-p org-registry-file) + (org-registry-initialize t)) + (find-file org-registry-file) + (goto-char (point-min)) + (while (re-search-forward (concat from-file "\")$") nil t) + (let ((end (1+ (match-end 0))) + (beg (progn (re-search-backward "^(\"" nil t) + (match-beginning 0)))) + (delete-region beg end))) + (goto-char (point-min)) + (re-search-forward "^(\"" nil t) + (goto-char (match-beginning 0)) + (mapc (lambda (elem) + (insert (with-output-to-string (prin1 elem)) "\n")) + new-entries) + (save-buffer) + (kill-buffer (current-buffer))) + (message (format "Org registry updated for %s" + (file-name-nondirectory from-file))))) + +(defun org-registry-create (entries) + "Create `org-registry-file' with ENTRIES." + (let (entry) + (with-temp-buffer + (find-file org-registry-file) + (erase-buffer) + (insert + (with-output-to-string + (princ ";; -*- emacs-lisp -*-\n") + (princ ";; Org registry\n") + (princ ";; You shouldn't try to modify this buffer manually\n\n") + (princ "(setq org-registry-alist\n'(\n") + (while entries + (when (setq entry (pop entries)) + (prin1 entry) + (princ "\n"))) + (princ "))\n"))) + (save-buffer) + (kill-buffer (current-buffer)))) + (message "Org registry created")) + +(provide 'org-registry) + +;;; User Options, Variables + +;;; org-registry.el ends here diff --git a/contrib/lisp/org-screen.el b/contrib/lisp/org-screen.el new file mode 100644 index 0000000..a517b4b --- /dev/null +++ b/contrib/lisp/org-screen.el @@ -0,0 +1,108 @@ +;;; org-screen.el --- Integreate Org-mode with screen. + +;; Copyright (c) 2008-2012 Andrew Hyatt +;; +;; Author: Andrew Hyatt <ahyatt at gmail dot com> +;; Maintainer: Carsten Dominik <carsten at orgmode dot org> +;; +;; This file is not yet part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This file contains functionality to integrate screen and org-mode. +;; When using org-mode, it is often useful to take tasks that have +;; some command-line work associated with them, and associate them +;; with a screen session. Screen is used rather than a direct +;; terminal to facilitate portability of the resulting session. +;; +;; To use screen in org, in your .emacs file, simply put this file in +;; a directory in your load-path and write: +;; +;; (require 'org-screen) +;; +;; When have a task and want to start some command-line activity +;; associated with that task, go to the end of your item and type: +;; +;; M-x org-screen +;; +;; This will prompt you for a name of a screen session. Type in a +;; name and it will insert a link into your org file at your current +;; location. +;; +;; When you want to visit the link, go to the link and type C-c C-o to +;; open the link. +;; +;; You may want to get rid of the constant queries about whether you +;; really want to execute lisp code. Do so by adding to your .emacs: +;; +;; (setq org-confirm-elisp-link-function nil) + +(require 'term) +(require 'org) + +(defcustom org-screen-program-name "/usr/bin/screen" + "Full location of the screen executable." + :group 'org-screen + :type 'string) + +(defun org-screen (name) + "Start a screen session with name" + (interactive "MScreen name: ") + (save-excursion + (org-screen-helper name "-S")) + (insert-string (concat "[[screen:" name "]]"))) + +(defun org-screen-buffer-name (name) + "Returns the buffer name corresponding to the screen name given." + (concat "*screen " name "*")) + +(defun org-screen-helper (name arg) + "This method will create a screen session with a specified name +and taking the specified screen arguments. Much of this function +is copied from ansi-term method." + + ;; Pick the name of the new buffer. + (let ((term-ansi-buffer-name + (generate-new-buffer-name + (org-screen-buffer-name name)))) + (setq term-ansi-buffer-name + (term-ansi-make-term + term-ansi-buffer-name org-screen-program-name nil arg name)) + (set-buffer term-ansi-buffer-name) + (term-mode) + (term-char-mode) + (term-set-escape-char ?\C-x) + term-ansi-buffer-name)) + +(defun org-screen-goto (name) + "Open the screen with the specified name in the window" + (interactive "MScreen name: ") + (let ((screen-buffer-name (org-screen-buffer-name name))) + (if (member screen-buffer-name + (mapcar 'buffer-name (buffer-list))) + (org-pop-to-buffer-same-window screen-buffer-name) + (org-pop-to-buffer-same-window (org-screen-helper name "-dr"))))) + +(if org-link-abbrev-alist + (add-to-list 'org-link-abbrev-alist + '("screen" . "elisp:(org-screen-goto \"%s\")")) + (setq org-link-abbrev-alist + '(("screen" . "elisp:(org-screen-goto \"%s\")")))) + +(provide 'org-screen) diff --git a/contrib/lisp/org-secretary.el b/contrib/lisp/org-secretary.el new file mode 100644 index 0000000..5db60f6 --- /dev/null +++ b/contrib/lisp/org-secretary.el @@ -0,0 +1,232 @@ +;;; org-secretary.el --- Team management with org-mode +;; Copyright (C) 2010-2012 Juan Reyero +;; +;; Author: Juan Reyero <juan _at_ juanreyero _dot_ com> +;; Keywords: outlines, tasks, team, management +;; Homepage: http://juanreyero.com/article/emacs/org-teams.html +;; Version: 0.02 +;; +;; This file is not part of GNU Emacs. +;; +;; This file is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; THis file is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This module implements helper functions for team management. It +;; makes it easy to keep track of the work of several people. It +;; keeps context (with whom and where you are) and allows you to use +;; it to metadata to your notes, and to query the tasks associated +;; with the people you are with and the place. +;; +;; See http://juanreyero.com/article/emacs/org-teams.html for a full +;; explanation and configuration instructions. +;; +;;; Configuration +;;;;;;;;;;;;;;;;; +;; +;; In short; your todos use the TODO keyword, your team's use TASK. +;; Your org-todo-keywords should look something like this: +;; +;; (setq org-todo-keywords +;; '((sequence "TODO(t)" "|" "DONE(d)" "CANCELLED(c)") +;; (sequence "TASK(f)" "|" "DONE(d)") +;; (sequence "MAYBE(m)" "|" "CANCELLED(c)"))) +;; +;; It helps to distinguish them by color, like this: +;; +;; (setq org-todo-keyword-faces +;; '(("TODO" . (:foreground "DarkOrange1" :weight bold)) +;; ("MAYBE" . (:foreground "sea green")) +;; ("DONE" . (:foreground "light sea green")) +;; ("CANCELLED" . (:foreground "forest green")) +;; ("TASK" . (:foreground "blue")))) +;; +;; If you want to keep track of stuck projects you should tag your +;; projects with :prj:, and define: +;; +;; (setq org-tags-exclude-from-inheritance '("prj") +;; org-stuck-projects '("+prj/-MAYBE-DONE" +;; ("TODO" "TASK") ())) +;; +;; Define a tag that marks TASK entries as yours: +;; +;; (setq org-sec-me "juanre") +;; +;; Finally, you add the special views to your org-agenda-custom-commands: +;; +;; (setq org-agenda-custom-commands +;; '(("h" "Work todos" tags-todo +;; "-personal-doat={.+}-dowith={.+}/!-TASK" +;; ((org-agenda-todo-ignore-scheduled t))) +;; ("H" "All work todos" tags-todo "-personal/!-TASK-MAYBE" +;; ((org-agenda-todo-ignore-scheduled nil))) +;; ("A" "Work todos with doat or dowith" tags-todo +;; "-personal+doat={.+}|dowith={.+}/!-TASK" +;; ((org-agenda-todo-ignore-scheduled nil))) +;; ("j" "TODO dowith and TASK with" +;; ((org-sec-with-view "TODO dowith") +;; (org-sec-where-view "TODO doat") +;; (org-sec-assigned-with-view "TASK with") +;; (org-sec-stuck-with-view "STUCK with"))) +;; ("J" "Interactive TODO dowith and TASK with" +;; ((org-sec-who-view "TODO dowith"))))) +;; +;;; Usage +;;;;;;;;; +;; +;; Do C-c w to say with whom you are meeting (a space-separated list +;; of names). Maybe do also C-c W to say where you are. Then do C-c a +;; j to see: +;; - Todo items defined with TODO (ie, mine) in which the +;; =dowith= property matches any of the people with me. +;; - Todo items defined with TODO in which the =doat= property +;; matches my current location. +;; - Todo items defined with TASK that are tagged with the name +;; of any of the people with me (this is, assigned to them). +;; - Stuck projects tagged with the name of the people with me. +;; +;; Use C-c j to add meta-data with the people with me, the +;; location and the time to entries. + +(require 'org) + +(defvar org-sec-me nil + "Tag that defines TASK todo entries associated to me") + +(defvar org-sec-with nil + "Value of the :with: property when doing an + org-sec-tag-entry. Change it with org-sec-set-with, + set to C-c w. Defaults to org-sec-me") + +(defvar org-sec-where "" + "Value of the :at: property when doing an + org-sec-tag-entry. Change it with org-sec-set-with, + set to C-c W") + +(defvar org-sec-with-history '() + "History list of :with: properties") + +(defvar org-sec-where-history '() + "History list of :where: properties") + +(defun org-sec-set-with () + "Changes the value of the org-sec-with variable for use in the + next call of org-sec-tag-entry. Leave it empty to default to + org-sec-me (you)." + (interactive) + (setq org-sec-with (let ((w (read-string "With: " nil + 'org-sec-with-history ""))) + (if (string= w "") + nil + w)))) +(global-set-key "\C-cw" 'org-sec-set-with) + +(defun org-sec-set-where () + "Changes the value of the org-sec-where variable for use + in the next call of org-sec-tag-entry." + (interactive) + (setq org-sec-where + (read-string "Where: " nil + 'org-sec-where-history ""))) +(global-set-key "\C-cW" 'org-sec-set-where) + +(defun org-sec-set-dowith () + "Sets the value of the dowith property." + (interactive) + (let ((do-with + (read-string "Do with: " + nil 'org-sec-dowith-history ""))) + (unless (string= do-with "") + (org-entry-put nil "dowith" do-with)))) +(global-set-key "\C-cd" 'org-sec-set-dowith) + +(defun org-sec-set-doat () + "Sets the value of the doat property." + (interactive) + (let ((do-at (read-string "Do at: " + nil 'org-sec-doat-history ""))) + (unless (string= do-at "") + (org-entry-put nil "doat" do-at)))) +(global-set-key "\C-cD" 'org-sec-set-doat) + +(defun org-sec-tag-entry () + "Adds a :with: property with the value of org-sec-with if + defined, an :at: property with the value of org-sec-where + if defined, and an :on: property with the current time." + (interactive) + (save-excursion + (org-entry-put nil "on" (format-time-string + (org-time-stamp-format 'long) + (current-time))) + (unless (string= org-sec-where "") + (org-entry-put nil "at" org-sec-where)) + (if org-sec-with + (org-entry-put nil "with" org-sec-with)))) +(global-set-key "\C-cj" 'org-sec-tag-entry) + +(defun join (lst sep &optional pre post) + (mapconcat (function (lambda (x) (concat pre x post))) lst sep)) + +(defun org-sec-get-with () + (if org-sec-with + org-sec-with + org-sec-me)) + +(defun org-sec-with-view (par &optional who) + "Select tasks marked as dowith=who, where who + defaults to the value of org-sec-with." + (org-tags-view '(4) (join (split-string (if who + who + (org-sec-get-with))) + "|" "dowith=\"" "\""))) + +(defun org-sec-where-view (par) + "Select tasks marked as doat=org-sec-where." + (org-tags-view '(4) (concat "doat={" org-sec-where "}"))) + +(defun org-sec-assigned-with-view (par &optional who) + "Select tasks assigned to who, by default org-sec-with." + (org-tags-view '(4) + (concat (join (split-string (if who + who + (org-sec-get-with))) + "|") + "/TASK"))) + +(defun org-sec-stuck-with-view (par &optional who) + "Select stuck projects assigned to who, by default + org-sec-with." + (let ((org-stuck-projects + `(,(concat "+prj+" + (join (split-string (if who + who + (org-sec-get-with))) "|") + "/-MAYBE-DONE") + ("TODO" "TASK") ()))) + (org-agenda-list-stuck-projects))) + +(defun org-sec-who-view (par) + "Builds agenda for a given user. Queried. " + (let ((who (read-string "Build todo for user/tag: " + "" "" ""))) + (org-sec-with-view "TODO dowith" who) + (org-sec-assigned-with-view "TASK with" who) + (org-sec-stuck-with-view "STUCK with" who))) + +(provide 'org-secretary) + +;;; org-secretary.el ends here diff --git a/contrib/lisp/org-static-mathjax.el b/contrib/lisp/org-static-mathjax.el new file mode 100644 index 0000000..29f2cfe --- /dev/null +++ b/contrib/lisp/org-static-mathjax.el @@ -0,0 +1,171 @@ +;;; org-static-mathjax.el --- Muse-like tags in Org-mode +;; +;; Author: Jan Böker <jan dot boecker at jboecker dot de> + +;; This elisp code integrates Static MathJax into the +;; HTML export process of Org-mode. +;; +;; The supporting files for this package are in contrib/scripts/staticmathjax +;; Please read the README.org file in that directory for more information. + +;; To use it, evaluate it on startup, add the following to your .emacs: + +;; (require 'org-static-mathjax) +;; +;; You will then have to customize the following two variables: +;; - org-static-mathjax-app-ini-path +;; - org-static-mathjax-local-mathjax-path +;; +;; If xulrunner is not in your $PATH, you will also need to customize +;; org-static-mathjax-xulrunner-path. +;; +;; If everything is setup correctly, you can trigger Static MathJax on +;; export to HTML by adding the following line to your Org file: +;; #+StaticMathJax: embed-fonts:nil output-file-name:"embedded-math.html" +;; +;; You can omit either argument. +;; embed-fonts defaults to nil. If you do not specify output-file-name, +;; the exported file is overwritten with the static version. +;; +;; If embed-fonts is non-nil, the fonts are embedded directly into the +;; output file using data: URIs. +;; +;; output-file-name specifies the file name of the static version. You +;; can use any arbitrary lisp form here, for example: +;; output-file-name:(concat (file-name-sans-extension buffer-file-name) "-static.html") +;; +;; The StaticMathJax XULRunner application expects a UTF-8 encoded +;; input file. If the static version displays random characters instead +;; of your math, add the following line at the top of your Org file: +;; -*- coding: utf-8; -*- +;; +;; License: GPL v2 or later + +(defcustom org-static-mathjax-app-ini-path + (or (expand-file-name + "../scripts/staticmatchjax/application.ini" + (file-name-directory (or load-file-name buffer-file-name))) + "") + "Path to \"application.ini\" of the Static MathJax XULRunner application. +If you have extracted StaticMathJax to e.g. ~/.local/staticmathjax, set +this to ~/.local/staticmathjax/application.ini" + :type 'string) + +(defcustom org-static-mathjax-xulrunner-path + "xulrunner" + "Path to your xulrunner binary" + :type 'string) + +(defcustom org-static-mathjax-local-mathjax-path + "" + "Extract the MathJax zip file somewhere on your local +hard drive and specify the path here. + +The directory has to be writeable, as org-static-mathjax +creates a temporary file there during export." + :type 'string) + +(defvar org-static-mathjax-debug + nil + "If non-nil, org-static-mathjax will print some debug messages") + +(defun org-static-mathjax-hook-installer () + "Installs org-static-mathjax-process in after-save-hook. + +Sets the following buffer-local variables for org-static-mathjax-process to pick up: +org-static-mathjax-mathjax-path: The path to MathJax.js as used by Org HTML export +org-static-mathjax-options: The string given with #+STATICMATHJAX: in the file" + (let ((static-mathjax-option-string (plist-get opt-plist :static-mathjax))) + (if static-mathjax-option-string + (progn (set (make-local-variable 'org-static-mathjax-options) static-mathjax-option-string) + (set (make-local-variable 'org-static-mathjax-mathjax-path) + (nth 1 (assq 'path org-export-html-mathjax-options))) + (let ((mathjax-options (plist-get opt-plist :mathjax))) + (if mathjax-options + (if (string-match "\\<path:" mathjax-options) + (set 'org-static-mathjax-mathjax-path + (car (read-from-string + (substring mathjax-options (match-end 0)))))))) + (add-hook 'after-save-hook + 'org-static-mathjax-process + nil t))))) + + +(defun org-static-mathjax-process () + (save-excursion + ; some sanity checking + (if (or (string= org-static-mathjax-app-ini-path "") + (not (file-exists-p org-static-mathjax-app-ini-path))) + (error "Static MathJax: You must customize org-static-mathjax-app-ini-path!")) + (if (or (string= org-static-mathjax-local-mathjax-path "") + (not (file-exists-p org-static-mathjax-local-mathjax-path))) + (error "Static MathJax: You must customize org-static-mathjax-local-mathjax-path!")) + + ; define variables + (let* ((options org-static-mathjax-options) + (output-file-name buffer-file-name) + (input-file-name (let ((temporary-file-directory (file-name-directory org-static-mathjax-local-mathjax-path))) + (make-temp-file "org-static-mathjax-" nil ".html"))) + (html-code (buffer-string)) + (mathjax-oldpath (concat "src=\"" org-static-mathjax-mathjax-path)) + (mathjax-newpath (concat "src=\"" org-static-mathjax-local-mathjax-path)) + embed-fonts) + ; read file-local options + (mapc + (lambda (symbol) + (if (string-match (concat "\\<" (symbol-name symbol) ":") options) + (set symbol (eval (car (read-from-string + (substring options (match-end 0)))))))) + '(embed-fonts output-file-name)) + + ; debug + (when org-static-mathjax-debug + (message "output file name, embed-fonts") + (print output-file-name) + (print embed-fonts)) + + ; open (temporary) input file, copy contents there, replace MathJax path with local installation + (with-temp-buffer + (insert html-code) + (goto-char 1) + (replace-regexp mathjax-oldpath mathjax-newpath) + (write-file input-file-name)) + + ; prepare argument list for call-process + (let ((call-process-args (list org-static-mathjax-xulrunner-path + nil nil nil + org-static-mathjax-app-ini-path + input-file-name + output-file-name))) + ; if fonts are embedded, just append the --embed-fonts flag + (if embed-fonts + (add-to-list 'call-process-args "--embed-fonts" t)) + ; if fonts are not embedded, the XULRunner app must replace all references + ; to the font files with the real location (Firefox inserts file:// URLs there, + ; because we are using a local MathJax installation here) + (if (not embed-fonts) + (progn + (add-to-list 'call-process-args "--final-mathjax-url" t) + (add-to-list 'call-process-args + (file-name-directory org-static-mathjax-mathjax-path) + t))) + + ; debug + (when org-static-mathjax-debug + (print call-process-args)) + ; call it + (apply 'call-process call-process-args) + ; delete our temporary input file + (kill-buffer) + (delete-file input-file-name) + (let ((backup-file (concat input-file-name "~"))) + (if (file-exists-p backup-file) + (delete-file backup-file))))))) + +(add-to-list 'org-export-inbuffer-options-extra +'("STATICMATHJAX" :static-mathjax)) + +(add-hook 'org-export-html-final-hook 'org-static-mathjax-hook-installer) + + +(provide 'org-static-mathjax) diff --git a/contrib/lisp/org-sudoku.el b/contrib/lisp/org-sudoku.el new file mode 100644 index 0000000..6977f1f --- /dev/null +++ b/contrib/lisp/org-sudoku.el @@ -0,0 +1,290 @@ +;;; org-sudoku.el --- Greate and solve SUDOKU games in Org tables + +;; Copyright (C) 2012 Free Software Foundation, Inc. +;; +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp, games +;; Homepage: http://orgmode.org +;; Version: 0.01 +;; +;; This file is not yet part of GNU Emacs. +;; +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs; see the file COPYING. If not, write to the +;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; This is a quick hack to create and solve SUDOKU games in org tables. +;; +;; Commands: +;; +;; org-sudoku-create Create a new SUDOKU game +;; org-sudoku-solve-field Solve the field at point in a SUDOKU game +;; (this is for cheeting when you are stuck) +;; org-sudoku-solve Solve the entire game +;; + +;;; Code + +(require 'org) +(require 'org-table) + +;;; Customization + +(defvar org-sudoku-size 9 + "The size of the sudoku game, 9 for a 9x9 game and 4 for a 4x4 game. +Larger games do not seem to work because of limited resources - even though +the algorithm is general.") + +(defvar org-sudoku-timeout 2.0 + "Timeout for finding a solution when creating a new game. +After this timeout, the program starts over from scratch to create +a game.") + +;;; Interactive commands + +(defun org-sudoku-create (nfilled) + "Create a sudoku game." + (interactive "nNumber of pre-filled fields: ") + (let ((sizesq org-sudoku-size) + game) + (loop for i from 1 to org-sudoku-size do + (loop for j from 1 to org-sudoku-size do + (push (list (cons i j) 0) game))) + (setq game (nreverse game)) + (random t) + (setq game (org-sudoku-build-allowed game)) + (setq game (org-sudoku-set-field game (cons 1 1) + (1+ (random org-sudoku-size)))) + (catch 'solved + (let ((cnt 0)) + (while t + (catch 'abort + (message "Attempt %d to create a game" (setq cnt (1+ cnt))) + (setq game1 (org-sudoku-deep-copy game)) + (setq game1 (org-sudoku-solve-game + game1 'random (+ (float-time) org-sudoku-timeout))) + (when game1 + (setq game game1) + (throw 'solved t)))))) + (let ((sqrtsize (floor (sqrt org-sudoku-size)))) + (loop for i from 1 to org-sudoku-size do + (insert "| |\n") + (if (and (= (mod i sqrtsize) 0) (< i org-sudoku-size)) + (insert "|-\n"))) + (backward-char 5) + (org-table-align)) + (while (> (length game) nfilled) + (setq game (delete (nth (1+ (random (length game))) game) game))) + (mapc (lambda (e) + (org-table-put (caar e) (cdar e) (int-to-string (nth 1 e)))) + game) + (org-table-align) + (org-table-goto-line 1) + (org-table-goto-column 1) + (message "Enjoy!"))) + +(defun org-sudoku-solve () + "Solve the sudoku game in the table at point." + (interactive) + (unless (org-at-table-p) + (error "not at a table")) + (let (game) + (setq game (org-sudoku-get-game)) + (setq game (org-sudoku-build-allowed game)) + (setq game (org-sudoku-solve-game game)) + ;; Insert the values + (mapc (lambda (e) + (org-table-put (caar e) (cdar e) (int-to-string (nth 1 e)))) + game) + (org-table-align))) + +(defun org-sudoku-solve-field () + "Just solve the field at point. +This works by solving the whole game, then inserting only the single field." + (interactive) + (unless (org-at-table-p) + (error "Not at a table")) + (org-table-check-inside-data-field) + (let ((i (org-table-current-dline)) + (j (org-table-current-column)) + game) + (setq game (org-sudoku-get-game)) + (setq game (org-sudoku-build-allowed game)) + (setq game (org-sudoku-solve-game game)) + (if game + (progn + (org-table-put i j (number-to-string + (nth 1 (assoc (cons i j) game))) + 'align) + (org-table-goto-line i) + (org-table-goto-column j)) + (error "No solution")))) + +;;; Internal functions + +(defun org-sudoku-get-game () + "Interpret table at point as sudoku game and read it. +A game structure is returned." + (let (b e g i j game) + + (org-table-goto-line 1) + (org-table-goto-column 1) + (setq b (point)) + (org-table-goto-line org-sudoku-size) + (org-table-goto-column org-sudoku-size) + (setq e (point)) + (setq g (org-table-copy-region b e)) + (setq i 0 j 0) + (mapc (lambda (c) + (setq i (1+ i) j 0) + (mapc + (lambda (v) + (setq j (1+ j)) + (push (list (cons i j) + (string-to-number v)) + game)) + c)) + g) + (nreverse game))) + +(defun org-sudoku-build-allowed (game) + (let (i j v numbers) + (loop for i from 1 to org-sudoku-size do + (push i numbers)) + (setq numbers (nreverse numbers)) + ;; add the lists of allowed values for each entry + (setq game (mapcar + (lambda (e) + (list (car e) (nth 1 e) + (if (= (nth 1 e) 0) + (copy-sequence numbers) + nil))) + game)) + ;; remove the known values from the list of allowed values + (mapc + (lambda (e) + (setq i (caar e) j (cdar e) v (cadr e)) + (when (> v 0) + ;; We do have a value here + (mapc + (lambda (f) + (setq a (assoc f game)) + (setf (nth 2 a) (delete v (nth 2 a)))) + (cons (cons i j) (org-sudoku-rel-fields i j))))) + game) + game)) + +(defun org-sudoku-find-next-constrained-field (game) + (setq game (mapcar (lambda (e) (if (nth 2 e) e nil)) game)) + (setq game (delq nil game)) + (let (va vb la lb) + (setq game + (sort game (lambda (a b) + (setq va (nth 1 a) vb (nth 1 b) + la (length (nth 2 a)) lb (length (nth 2 b))) + (cond + ((and (= va 0) (> vb 0)) t) + ((and (> va 0) (= vb 0)) nil) + ((not (= (* va vb) 0)) nil) + (t (< la lb)))))) + (if (or (not game) (> 0 (nth 1 (car game)))) + nil + (caar game)))) + +(defun org-sudoku-solve-game (game &optional random stop-at) + "Solve GAME. +If RANDOM is non-nit, select candidates randomly from a fields option. +If RANDOM is nil, always start with the first allowed value and try +solving from there. +STOP-AT can be a float time, the solver will abort at that time because +it is probably stuck." + (let (e v v1 allowed next g) + (when (and stop-at + (> (float-time) stop-at)) + (setq game nil) + (throw 'abort nil)) + (while (setq next (org-sudoku-find-next-constrained-field game)) + (setq e (assoc next game) + v (nth 1 e) + allowed (nth 2 e)) + (catch 'solved + (if (= (length allowed) 1) + (setq game (org-sudoku-set-field game next (car allowed))) + (while allowed + (setq g (org-sudoku-deep-copy game)) + (if (not random) + (setq v1 (car allowed)) + (setq v1 (nth (random (length allowed)) allowed))) + (setq g (org-sudoku-set-field g next v1)) + (setq g (org-sudoku-solve-game g random stop-at)) + (when g + (setq game g) + (throw 'solved g))) + (setq game nil)))) + (if (or (not game) + (org-sudoku-unknown-field-p game)) + nil + game))) + +(defun org-sudoku-unknown-field-p (game) + "Are there still unknown fields in the game?" + (delq nil (mapcar (lambda (e) (if (> (nth 1 e) 0) nil t)) game))) + +(defun org-sudoku-deep-copy (game) + "Make a copy of the game so that manipulating the copy does not change the parent." + (mapcar (lambda(e) + (list (car e) (nth 1 e) (copy-sequence (nth 2 e)))) + game)) + +(defun org-sudoku-set-field (game field value) + "Put VALUE into FIELD, and tell related fields that they cannot be VALUE." + (let (i j) + (setq i (car field) j (cdr field)) + (setq a (assoc field game)) + (setf (nth 1 a) value) + (setf (nth 2 a) nil) + + ;; Remove value from all related fields + (mapc + (lambda (f) + (setq a (assoc f game)) + (setf (nth 2 a) (delete value (nth 2 a)))) + (org-sudoku-rel-fields i j)) + game)) + +(defun org-sudoku-rel-fields (i j) + "Compute the list of related fields for field (i j)." + (let ((sqrtsize (floor (sqrt org-sudoku-size))) + ll imin imax jmin jmax f) + (setq f (cons i j)) + (loop for ii from 1 to org-sudoku-size do + (or (= ii i) (push (cons ii j) ll))) + (loop for jj from 1 to org-sudoku-size do + (or (= jj j) (push (cons i jj) ll))) + (setq imin (1+ (* sqrtsize (/ (1- i) sqrtsize))) + imax (+ imin sqrtsize -1)) + (setq jmin (1+ (* sqrtsize (/ (1- j) sqrtsize))) + jmax (+ jmin sqrtsize -1)) + (loop for ii from imin to imax do + (loop for jj from jmin to jmax do + (setq ff (cons ii jj)) + (or (equal ff f) + (member ff ll) + (push ff ll)))) + ll)) + +;;; org-sudoku ends here diff --git a/contrib/lisp/org-toc.el b/contrib/lisp/org-toc.el new file mode 100644 index 0000000..3f37cb8 --- /dev/null +++ b/contrib/lisp/org-toc.el @@ -0,0 +1,488 @@ +;;; org-toc.el --- Table of contents for Org-mode buffer + +;; Copyright 2007-2012 Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry <bzg AT gnu DOT org> +;; Keywords: Org table of contents +;; Homepage: http://www.cognition.ens.fr/~guerry/u/org-toc.el +;; Version: 0.8 + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; if not, write to the Free Software +;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;; Commentary: + +;; This library implements a browsable table of contents for Org files. + +;; Put this file into your load-path and the following into your ~/.emacs: +;; (require 'org-toc) + +;;; Code: + +(provide 'org-toc) +(eval-when-compile + (require 'cl)) + +;;; Custom variables: +(defvar org-toc-base-buffer nil) +(defvar org-toc-columns-shown nil) +(defvar org-toc-odd-levels-only nil) +(defvar org-toc-config-alist nil) +(defvar org-toc-cycle-global-status nil) +(defalias 'org-show-table-of-contents 'org-toc-show) + +(defgroup org-toc nil + "Options concerning the browsable table of contents of Org-mode." + :tag "Org TOC" + :group 'org) + +(defcustom org-toc-default-depth 1 + "Default depth when invoking `org-toc-show' without argument." + :group 'org-toc + :type '(choice + (const :tag "same as base buffer" nil) + (integer :tag "level"))) + +(defcustom org-toc-follow-mode nil + "Non-nil means navigating through the table of contents will +move the point in the Org buffer accordingly." + :group 'org-toc + :type 'boolean) + +(defcustom org-toc-info-mode nil + "Non-nil means navigating through the table of contents will +show the properties for the current headline in the echo-area." + :group 'org-toc + :type 'boolean) + +(defcustom org-toc-show-subtree-mode nil + "Non-nil means show subtree when going to headline or following +it while browsing the table of contents." + :group 'org-toc + :type '(choice + (const :tag "show subtree" t) + (const :tag "show entry" nil))) + +(defcustom org-toc-recenter-mode t + "Non-nil means recenter the Org buffer when following the +headlines in the TOC buffer." + :group 'org-toc + :type 'boolean) + +(defcustom org-toc-recenter 0 + "Where to recenter the Org buffer when unfolding a subtree. +This variable is only used when `org-toc-recenter-mode' is set to +'custom. A value >=1000 will call recenter with no arg." + :group 'org-toc + :type 'integer) + +(defcustom org-toc-info-exclude '("ALLTAGS") + "A list of excluded properties when displaying info in the +echo-area. The COLUMNS property is always exluded." + :group 'org-toc + :type 'lits) + +;;; Org TOC mode: +(defvar org-toc-mode-map (make-sparse-keymap) + "Keymap for `org-toc-mode'.") + +(defun org-toc-mode () + "A major mode for browsing the table of contents of an Org buffer. + +\\{org-toc-mode-map}" + (interactive) + (kill-all-local-variables) + (use-local-map org-toc-mode-map) + (setq mode-name "Org TOC") + (setq major-mode 'org-toc-mode)) + +;; toggle modes +(define-key org-toc-mode-map "f" 'org-toc-follow-mode) +(define-key org-toc-mode-map "S" 'org-toc-show-subtree-mode) +(define-key org-toc-mode-map "s" 'org-toc-store-config) +(define-key org-toc-mode-map "g" 'org-toc-restore-config) +(define-key org-toc-mode-map "i" 'org-toc-info-mode) +(define-key org-toc-mode-map "r" 'org-toc-recenter-mode) + +;; navigation keys +(define-key org-toc-mode-map "p" 'org-toc-previous) +(define-key org-toc-mode-map "n" 'org-toc-next) +(define-key org-toc-mode-map [(left)] 'org-toc-previous) +(define-key org-toc-mode-map [(right)] 'org-toc-next) +(define-key org-toc-mode-map [(up)] 'org-toc-previous) +(define-key org-toc-mode-map [(down)] 'org-toc-next) +(define-key org-toc-mode-map "1" (lambda() (interactive) (org-toc-show 1 (point)))) +(define-key org-toc-mode-map "2" (lambda() (interactive) (org-toc-show 2 (point)))) +(define-key org-toc-mode-map "3" (lambda() (interactive) (org-toc-show 3 (point)))) +(define-key org-toc-mode-map "4" (lambda() (interactive) (org-toc-show 4 (point)))) +(define-key org-toc-mode-map " " 'org-toc-goto) +(define-key org-toc-mode-map "q" 'org-toc-quit) +(define-key org-toc-mode-map "x" 'org-toc-quit) +;; go to the location and stay in the base buffer +(define-key org-toc-mode-map [(tab)] 'org-toc-jump) +(define-key org-toc-mode-map "v" 'org-toc-jump) +;; go to the location and delete other windows +(define-key org-toc-mode-map [(return)] + (lambda() (interactive) (org-toc-jump t))) + +;; special keys +(define-key org-toc-mode-map "c" 'org-toc-columns) +(define-key org-toc-mode-map "?" 'org-toc-help) +(define-key org-toc-mode-map ":" 'org-toc-cycle-subtree) +(define-key org-toc-mode-map "\C-c\C-o" 'org-open-at-point) +;; global cycling in the base buffer +(define-key org-toc-mode-map (kbd "C-S-<iso-lefttab>") + 'org-toc-cycle-base-buffer) +;; subtree cycling in the base buffer +(define-key org-toc-mode-map [(control tab)] + (lambda() (interactive) (org-toc-goto nil t))) + +;;; Toggle functions: +(defun org-toc-follow-mode () + "Toggle follow mode in a `org-toc-mode' buffer." + (interactive) + (setq org-toc-follow-mode (not org-toc-follow-mode)) + (message "Follow mode is %s" + (if org-toc-follow-mode "on" "off"))) + +(defun org-toc-info-mode () + "Toggle info mode in a `org-toc-mode' buffer." + (interactive) + (setq org-toc-info-mode (not org-toc-info-mode)) + (message "Info mode is %s" + (if org-toc-info-mode "on" "off"))) + +(defun org-toc-show-subtree-mode () + "Toggle show subtree mode in a `org-toc-mode' buffer." + (interactive) + (setq org-toc-show-subtree-mode (not org-toc-show-subtree-mode)) + (message "Show subtree mode is %s" + (if org-toc-show-subtree-mode "on" "off"))) + +(defun org-toc-recenter-mode (&optional line) + "Toggle recenter mode in a `org-toc-mode' buffer. If LINE is +specified, then make `org-toc-recenter' use this value." + (interactive "P") + (setq org-toc-recenter-mode (not org-toc-recenter-mode)) + (when (numberp line) + (setq org-toc-recenter-mode t) + (setq org-toc-recenter line)) + (message "Recenter mode is %s" + (if org-toc-recenter-mode + (format "on, line %d" org-toc-recenter) "off"))) + +(defun org-toc-cycle-subtree () + "Locally cycle a headline through two states: 'children and +'folded" + (interactive) + (let ((beg (point)) + (end (save-excursion (end-of-line) (point))) + (ov (car (overlays-at (point)))) + status) + (if ov (setq status (overlay-get ov 'status)) + (setq ov (make-overlay beg end))) + ;; change the folding status of this headline + (cond ((or (null status) (eq status 'folded)) + (show-children) + (message "CHILDREN") + (overlay-put ov 'status 'children)) + ((eq status 'children) + (show-branches) + (message "BRANCHES") + (overlay-put ov 'status 'branches)) + (t (hide-subtree) + (message "FOLDED") + (overlay-put ov 'status 'folded))))) + +;;; Main show function: +;; FIXME name this org-before-first-heading-p? +(defun org-toc-before-first-heading-p () + "Before first heading?" + (save-excursion + (null (re-search-backward org-outline-regexp-bol nil t)))) + +;;;###autoload +(defun org-toc-show (&optional depth position) + "Show the table of contents of the current Org-mode buffer." + (interactive "P") + (if (eq major-mode 'org-mode) + (progn (setq org-toc-base-buffer (current-buffer)) + (setq org-toc-odd-levels-only org-odd-levels-only)) + (if (eq major-mode 'org-toc-mode) + (org-pop-to-buffer-same-window org-toc-base-buffer) + (error "Not in an Org buffer"))) + ;; create the new window display + (let ((pos (or position + (save-excursion + (if (org-toc-before-first-heading-p) + (progn (re-search-forward org-outline-regexp-bol nil t) + (match-beginning 0)) + (point)))))) + (setq org-toc-cycle-global-status org-cycle-global-status) + (delete-other-windows) + (and (get-buffer "*org-toc*") (kill-buffer "*org-toc*")) + (switch-to-buffer-other-window + (make-indirect-buffer org-toc-base-buffer "*org-toc*")) + ;; make content before 1st headline invisible + (goto-char (point-min)) + (let* ((beg (point-min)) + (end (and (re-search-forward "^\\*" nil t) + (1- (match-beginning 0)))) + (ov (make-overlay beg end)) + (help (format "Table of contents for %s (press ? for a quick help):\n" + (buffer-name org-toc-base-buffer)))) + (overlay-put ov 'invisible t) + (overlay-put ov 'before-string help)) + ;; build the browsable TOC + (cond (depth + (let* ((dpth (if org-toc-odd-levels-only + (1- (* depth 2)) depth))) + (org-content dpth) + (setq org-toc-cycle-global-status + `(org-content ,dpth)))) + ((null org-toc-default-depth) + (if (eq org-toc-cycle-global-status 'overview) + (progn (org-overview) + (setq org-cycle-global-status 'overview) + (run-hook-with-args 'org-cycle-hook 'overview)) + (progn (org-overview) + ;; FIXME org-content to show only headlines? + (org-content) + (setq org-cycle-global-status 'contents) + (run-hook-with-args 'org-cycle-hook 'contents)))) + (t (let* ((dpth0 org-toc-default-depth) + (dpth (if org-toc-odd-levels-only + (1- (* dpth0 2)) dpth0))) + (org-content dpth) + (setq org-toc-cycle-global-status + `(org-content ,dpth))))) + (goto-char pos)) + (move-beginning-of-line nil) + (org-toc-mode) + (shrink-window-if-larger-than-buffer) + (setq buffer-read-only t)) + +;;; Navigation functions: +(defun org-toc-goto (&optional jump cycle) + "From Org TOC buffer, follow the targeted subtree in the Org window. +If JUMP is non-nil, go to the base buffer. +If JUMP is 'delete, go to the base buffer and delete other windows. +If CYCLE is non-nil, cycle the targeted subtree in the Org window." + (interactive) + (let ((pos (point)) + (toc-buf (current-buffer))) + (switch-to-buffer-other-window org-toc-base-buffer) + (goto-char pos) + (if cycle (org-cycle) + (progn (org-overview) + (if org-toc-show-subtree-mode + (org-show-subtree) + (org-show-entry)) + (org-show-context))) + (if org-toc-recenter-mode + (if (>= org-toc-recenter 1000) (recenter) + (recenter org-toc-recenter))) + (cond ((null jump) + (switch-to-buffer-other-window toc-buf)) + ((eq jump 'delete) + (delete-other-windows))))) + +(defun org-toc-cycle-base-buffer () + "Call `org-cycle' with a prefix argument in the base buffer." + (interactive) + (switch-to-buffer-other-window org-toc-base-buffer) + (org-cycle t) + (other-window 1)) + +(defun org-toc-jump (&optional delete) + "From Org TOC buffer, jump to the targeted subtree in the Org window. +If DELETE is non-nil, delete other windows when in the Org buffer." + (interactive "P") + (if delete (org-toc-goto 'delete) + (org-toc-goto t))) + +(defun org-toc-previous () + "Go to the previous headline of the TOC." + (interactive) + (if (save-excursion + (beginning-of-line) + (re-search-backward "^\\*" nil t)) + (outline-previous-visible-heading 1) + (message "No previous heading")) + (if org-toc-info-mode (org-toc-info)) + (if org-toc-follow-mode (org-toc-goto))) + +(defun org-toc-next () + "Go to the next headline of the TOC." + (interactive) + (outline-next-visible-heading 1) + (if org-toc-info-mode (org-toc-info)) + (if org-toc-follow-mode (org-toc-goto))) + +(defun org-toc-quit () + "Quit the current Org TOC buffer." + (interactive) + (kill-this-buffer) + (other-window 1) + (delete-other-windows)) + +;;; Special functions: +(defun org-toc-columns () + "Toggle columns view in the Org buffer from Org TOC." + (interactive) + (let ((indirect-buffer (current-buffer))) + (org-pop-to-buffer-same-window org-toc-base-buffer) + (if (not org-toc-columns-shown) + (progn (org-columns) + (setq org-toc-columns-shown t)) + (progn (org-columns-remove-overlays) + (setq org-toc-columns-shown nil))) + (org-pop-to-buffer-same-window indirect-buffer))) + +(defun org-toc-info () + "Show properties of current subtree in the echo-area." + (interactive) + (let ((pos (point)) + (indirect-buffer (current-buffer)) + props prop msg) + (org-pop-to-buffer-same-window org-toc-base-buffer) + (goto-char pos) + (setq props (org-entry-properties)) + (while (setq prop (pop props)) + (unless (or (equal (car prop) "COLUMNS") + (member (car prop) org-toc-info-exclude)) + (let ((p (car prop)) + (v (cdr prop))) + (if (equal p "TAGS") + (setq v (mapconcat 'identity (split-string v ":" t) " "))) + (setq p (concat p ":")) + (add-text-properties 0 (length p) '(face org-special-keyword) p) + (setq msg (concat msg p " " v " "))))) + (org-pop-to-buffer-same-window indirect-buffer) + (message msg))) + +;;; Store and restore TOC configuration: +(defun org-toc-store-config () + "Store the current status of the tables of contents in +`org-toc-config-alist'." + (interactive) + (let ((file (buffer-file-name org-toc-base-buffer)) + (pos (point)) + (hlcfg (org-toc-get-headlines-status))) + (setq org-toc-config-alist + (delete (assoc file org-toc-config-alist) + org-toc-config-alist)) + (add-to-list 'org-toc-config-alist + `(,file ,pos ,org-toc-cycle-global-status ,hlcfg)) + (message "TOC configuration saved: (%s)" + (if (listp org-toc-cycle-global-status) + (concat "org-content " + (number-to-string + (cadr org-toc-cycle-global-status))) + (symbol-name org-toc-cycle-global-status))))) + +(defun org-toc-restore-config () + "Get the stored status in `org-toc-config-alist' and set the +current table of contents to it." + (interactive) + (let* ((file (buffer-file-name org-toc-base-buffer)) + (conf (cdr (assoc file org-toc-config-alist))) + (pos (car conf)) + (status (cadr conf)) + (hlcfg (caddr conf)) hlcfg0 ov) + (cond ((listp status) + (org-toc-show (cadr status) (point))) + ((eq status 'overview) + (org-overview) + (setq org-cycle-global-status 'overview) + (run-hook-with-args 'org-cycle-hook 'overview)) + (t + (org-overview) + (org-content) + (setq org-cycle-global-status 'contents) + (run-hook-with-args 'org-cycle-hook 'contents))) + (while (setq hlcfg0 (pop hlcfg)) + (save-excursion + (goto-char (point-min)) + (when (search-forward (car hlcfg0) nil t) + (unless (overlays-at (match-beginning 0)) + (setq ov (make-overlay (match-beginning 0) + (match-end 0)))) + (cond ((eq (cdr hlcfg0) 'children) + (show-children) + (message "CHILDREN") + (overlay-put ov 'status 'children)) + ((eq (cdr hlcfg0) 'branches) + (show-branches) + (message "BRANCHES") + (overlay-put ov 'status 'branches)))))) + (goto-char pos) + (if org-toc-follow-mode (org-toc-goto)) + (message "Last TOC configuration restored") + (sit-for 1) + (if org-toc-info-mode (org-toc-info)))) + +(defun org-toc-get-headlines-status () + "Return an alist of headlines and their associated folding +status." + (let (output ovs) + (save-excursion + (goto-char (point-min)) + (while (and (not (eobp)) + (goto-char (next-overlay-change (point)))) + (when (looking-at org-outline-regexp-bol) + (add-to-list + 'output + (cons (buffer-substring-no-properties + (match-beginning 0) + (save-excursion + (end-of-line) (point))) + (overlay-get + (car (overlays-at (point))) 'status)))))) + ;; return an alist like (("* Headline" . 'status)) + output)) + +;; In Org TOC buffer, hide headlines below the first level. +(defun org-toc-help () + "Display a quick help message in the echo-area for `org-toc-mode'." + (interactive) + (let ((st-start 0) + (help-message + "\[space\] show heading \[1-4\] hide headlines below this level +\[TAB\] jump to heading \[f\] toggle follow mode (currently %s) +\[return\] jump and delete others windows \[i\] toggle info mode (currently %s) +\[S-TAB\] cycle subtree (in Org) \[S\] toggle show subtree mode (currently %s) +\[C-S-TAB\] global cycle (in Org) \[r\] toggle recenter mode (currently %s) +\[:\] cycle subtree (in TOC) \[c\] toggle column view (currently %s) +\[n/p\] next/previous heading \[s\] save TOC configuration +\[q\] quit the TOC \[g\] restore last TOC configuration")) + (while (string-match "\\[[^]]+\\]" help-message st-start) + (add-text-properties (match-beginning 0) + (match-end 0) '(face bold) help-message) + (setq st-start (match-end 0))) + (message help-message + (if org-toc-follow-mode "on" "off") + (if org-toc-info-mode "on" "off") + (if org-toc-show-subtree-mode "on" "off") + (if org-toc-recenter-mode (format "on, line %s" org-toc-recenter) "off") + (if org-toc-columns-shown "on" "off")))) + + +;;;;########################################################################## +;;;; User Options, Variables +;;;;########################################################################## + +;;; org-toc.el ends here diff --git a/contrib/lisp/org-track.el b/contrib/lisp/org-track.el new file mode 100644 index 0000000..1d12862 --- /dev/null +++ b/contrib/lisp/org-track.el @@ -0,0 +1,219 @@ +;;; org-track.el --- Track the most recent Org-mode version available. +;; +;; Copyright (C) 2009-2012 +;; Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry <bzg at altern dot org> +;; Eric S Fraga <e.fraga at ucl.ac dot uk> +;; Sebastian Rose <sebastian_rose at gmx dot de> +;; The Worg people http://orgmode.org/worg/ +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 6.29a +;; +;; Released under the GNU General Public License version 3 +;; see: http://www.gnu.org/licenses/gpl-3.0.html +;; +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: +;; +;; Download the latest development tarball, unpack and optionally compile it +;; +;; Usage: +;; +;; (require 'org-track) +;; +;; ;; ... somewhere in your setup (use customize): +;; +;; (setq org-track-directory "~/test/") +;; (setq org-track-compile-sources nil) +;; (setq org-track-remove-package t) +;; +;; M-x org-track-update RET + + + +(require 'url-parse) +(require 'url-handlers) +(autoload 'url-file-local-copy "url-handlers") +(autoload 'url-generic-parse-url "url-parse") + + + + + +;;; Variables: + +(defgroup org-track nil + "Track the most recent Org-mode version available. + +To use org-track, adjust `org-track-directory'. +Org will download the archived latest git version for you, +unpack it into that directory (i.e. a subdirectory +`org-mode/' is added), create the autoloads file +`org-install.el' for you and, optionally, compile the +sources. +All you'll have to do is call `M-x org-track-update' from +time to time." + :version "22.1" + :group 'org) + +(defcustom org-track-directory "~/.emacs.d/org/lisp" + "Directory where your org-mode/ directory lives. +If that directory does not exist, it will be created." + :type 'directory) + +(defcustom org-track-compile-sources t + "If `nil', never compile org-sources. +Org will only create the autoloads file `org-install.el' for +you then. If `t', compile the sources, too. +Note, that emacs preferes compiled elisp files over +non-compiled ones." + :type 'boolean) + +(defcustom org-track-org-url "http://orgmode.org/" + "The URL where the package to download can be found. +Please append a slash." + :type 'string) + +(defcustom org-track-org-package "org-latest.tar.gz" + "The basename of the package you use. +Defaults to the development version of Org-mode. +This should be a *.tar.gz package, since emacs provides all +you need to unpack it." + :type 'string) + +(defcustom org-track-remove-package nil + "Remove org-latest.tar.gz after updates?" + :type 'boolean) + + + + + +;;; Frontend + +(defun org-track-update () + "Update to current Org-mode version. +Also, generate autoloads and evtl. compile the sources." + (interactive) + (let* ((base (file-truename org-track-directory)) + (org-exists (file-exists-p + (file-truename + (concat base "/org-mode/lisp/org.el")))) + (nobase (not (file-directory-p + (file-truename org-track-directory))))) + (if nobase + (when (y-or-n-p + (format "Directory %s does not exist. Create it?" base)) + (make-directory base t) + (setq nobase nil))) + (if nobase + (message "Not creating %s - giving up." org-track-directory) + (condition-case err + (progn + (org-track-fetch-package) + (org-track-compile-org)) + (error (message "%s" (error-message-string err))))))) + + + + +;;; tar related functions + +;; `url-retrieve-synchronously' fetches files synchronously. How can we ensure +;; that? If the maintainers of that package decide, that an assynchronous +;; download might be better??? (used by `url-file-local-copy') + +;;;###autoload +(defun org-track-fetch-package (&optional directory) + "Fetch Org package depending on `org-track-fetch-package-extension'. +If DIRECTORY is defined, unpack the package there, i.e. add the +subdirectory org-mode/ to DIRECTORY." + (interactive "Dorg-track directory: ") + (let* ((pack (concat + (if (string-match "/$" org-track-org-url) + org-track-org-url + (concat org-track-org-url "/")) + org-track-org-package)) + (base (file-truename + (or directory org-track-directory))) + (target (file-truename + (concat base "/" org-track-org-package))) + url download tarbuff) + (message "Fetching to %s - this might take some time..." base) + (setq url (url-generic-parse-url pack)) + (setq download (url-file-local-copy url)) ;; errors if fail + (copy-file download target t) + (delete-file download) + ;; (tar-mode) leads to dubious errors. We use the auto-mode-alist to + ;; ensure tar-mode is used: + (add-to-list 'auto-mode-alist '("org-latest\\.tar\\.gz\\'" . tar-mode)) + (setq tarbuff (find-file target)) + (with-current-buffer tarbuff ;; with-temp-buffer does not work with tar-mode?? + (tar-untar-buffer)) + (kill-buffer tarbuff) + (if org-track-remove-package + (delete-file target)))) + + + + +;;; Compile Org-mode sources + + +;;;###autoload +(defun org-track-compile-org (&optional directory) + "Compile all *.el files that come with org-mode. +Generate the autoloads file `org-install.el'. + +DIRECTORY is where the directory org-mode/ lives (i.e. the + parent directory of your local repo." + (interactive) + ;; file-truename expands the filename and removes double slash, if exists: + (setq directory (file-truename + (concat + (or directory + (file-truename (concat org-track-directory "/org-mode/lisp"))) + "/"))) + (add-to-list 'load-path directory) + (let ((list-of-org-files (file-expand-wildcards (concat directory "*.el")))) + ;; create the org-install file + (require 'autoload) + (setq esf/org-install-file (concat directory "org-install.el")) + (find-file esf/org-install-file) + (erase-buffer) + (mapc (lambda (x) + (generate-file-autoloads x)) + list-of-org-files) + (insert "\n(provide (quote org-install))\n") + (save-buffer) + (kill-buffer) + (byte-compile-file esf/org-install-file t) + + (mapc (lambda (f) + (if (file-exists-p (concat f "c")) + (delete-file (concat f "c")))) + list-of-org-files) + (if org-track-compile-sources + (mapc (lambda (f) (byte-compile-file f)) list-of-org-files)))) + + +(provide 'org-track) + +;;; org-track.el ends here diff --git a/contrib/lisp/org-velocity.el b/contrib/lisp/org-velocity.el new file mode 100644 index 0000000..7425d32 --- /dev/null +++ b/contrib/lisp/org-velocity.el @@ -0,0 +1,724 @@ +;;; org-velocity.el --- something like Notational Velocity for Org. + +;; Copyright (C) 2010-2012 Paul M. Rodriguez + +;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com> +;; Created: 2010-05-05 +;; Version: 3.0 + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation version 2. + +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. + +;; For a copy of the GNU General Public License, search the Internet, +;; or write to the Free Software Foundation, Inc., 59 Temple Place, +;; Suite 330, Boston, MA 02111-1307 USA + +;;; Commentary: +;; Org-Velocity.el is an interface for Org inspired by the minimalist +;; notetaking program Notational Velocity. The idea is to let you +;; amass and access brief notes on many subjects with minimal fuss. +;; Each note is an entry in an ordinary Org file. + +;; Org-Velocity can be used in two ways: when called outside Org, to +;; store and access notes in a designated bucket file; or, when called +;; inside Org, as a method for navigating any Org file. (Setting the +;; option `org-velocity-always-use-bucket' disables navigation inside +;; Org files by default, although you can still force this behavior by +;; calling `org-velocity-read' with an argument.) + +;; Org-Velocity prompts for search terms in the minibuffer. A list of +;; headings of entries whose text matches your search is updated as +;; you type; you can end the search and visit an entry at any time by +;; clicking on its heading. + +;; RET displays the results. If there are no matches, Org-Velocity +;; offers to create a new entry with your search string as its +;; heading. If there are matches, it displays a list of results where +;; the heading of each matching entry is hinted with a number or +;; letter; clicking a result, or typing the matching hint, opens the +;; entry for editing in an indirect buffer. 0 forces a new entry; RET +;; reopens the search for editing. + +;; You can customize every step in this process, including the search +;; method, completion for search terms, and templates for creating new +;; entries; M-x customize-group RET org-velocity RET to see all the +;; options. + +;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff +;; Horn for their suggestions. + +;;; Usage: +;; (require 'org-velocity) +;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory)) +;; (global-set-key (kbd "C-c v") 'org-velocity) + +;;; Code: +(require 'org) +(require 'button) +(require 'electric) +(require 'dabbrev) +(eval-when-compile (require 'cl)) + +(defgroup org-velocity nil + "Notational Velocity-style interface for Org." + :tag "Org-Velocity" + :group 'outlines + :group 'hypermedia + :group 'org) + +(defcustom org-velocity-bucket "" + "Where is the bucket file?" + :group 'org-velocity + :type 'file) + +(defcustom org-velocity-search-is-incremental t + "Show results incrementally when possible?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-show-previews t + "Show previews of the text of each heading?" + :group 'velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-exit-on-match nil + "When searching incrementally, exit on a single match?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-force-new nil + "Should exiting the minibuffer with C-j force a new entry?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-use-search-ring t + "Push search to `search-ring' when visiting an entry? + +This means that C-s C-s will take you directly to the first +instance of the search string." + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-always-use-bucket nil + "Use bucket file even when called from an Org buffer?" + :group 'org-velocity + :type 'boolean + :safe 'booleanp) + +(defcustom org-velocity-use-completion nil + "Use completion? + +Notwithstanding the value of this option, calling +`dabbrev-expand' always completes against the text of the bucket +file." + :group 'org-velocity + :type '(choice + (const :tag "Do not use completion" nil) + (const :tag "Use completion" t)) + :safe 'booleanp) + +(defcustom org-velocity-search-method 'phrase + "Match on whole phrase, any word, or all words?" + :group 'org-velocity + :type '(choice + (const :tag "Match whole phrase" phrase) + (const :tag "Match any word" any) + (const :tag "Match all words" all) + (const :tag "Match a regular expression" regexp)) + :safe (lambda (v) (memq v '(phrase any all regexp)))) + +(defcustom org-velocity-capture-templates + '(("v" + "Velocity entry" + entry + (file "") + "* %:search\n\n%i%?")) + "Use these template with `org-capture'. +Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'. +The keyword :search inserts the current search. +See the documentation for `org-capture-templates'." + :group 'org-velocity + :type (or (get 'org-capture-templates 'custom-type) 'list)) + +(defsubst org-velocity-grab-preview () + "Grab preview of a subtree. +The length of the preview is determined by `window-width'. + +Replace all contiguous whitespace with single spaces." + (let ((start (progn + (forward-line 1) + (if (looking-at org-property-start-re) + (re-search-forward org-property-end-re) + (1- (point)))))) + (mapconcat + #'identity + (split-string + (buffer-substring-no-properties + start + (min + (+ start (window-width)) + (point-max)))) + " "))) + +(defstruct org-velocity-heading buffer position name level preview) + +(defsubst org-velocity-nearest-heading (position) + "Return last heading at POSITION. +If there is no last heading, return nil." + (save-excursion + (goto-char position) + (re-search-backward org-velocity-heading-regexp) + (let ((components (org-heading-components))) + (make-org-velocity-heading + :buffer (current-buffer) + :position (point) + :name (nth 4 components) + :level (nth 0 components) + :preview (if org-velocity-show-previews + (org-velocity-grab-preview)))))) + +(defconst org-velocity-index + (eval-when-compile + (nconc (number-sequence 49 57) ;numbers + (number-sequence 97 122) ;lowercase letters + (number-sequence 65 90))) ;uppercase letters + "List of chars for indexing results.") + +(defconst org-velocity-match-buffer-name "*Velocity matches*") + +(defconst org-velocity-heading-regexp "^\\* " + "Regexp to match only top-level headings.") + +(defvar org-velocity-search nil + "Variable to bind to current search.") + +(defun org-velocity-buffer-file-name (&optional buffer) + "Return the name of the file BUFFER saves to. +Same as function `buffer-file-name' unless BUFFER is an indirect +buffer or a minibuffer. In the former case, return the file name +of the base buffer; in the latter, return the file name of +`minibuffer-selected-window' (or its base buffer)." + (let ((buffer (if (minibufferp buffer) + (window-buffer (minibuffer-selected-window)) + buffer))) + (buffer-file-name + (or (buffer-base-buffer buffer) + buffer)))) + +(defun org-velocity-minibuffer-contents () + "Return the contents of the minibuffer when it is active." + (if (active-minibuffer-window) + (with-current-buffer (window-buffer (active-minibuffer-window)) + (minibuffer-contents)))) + +(defsubst org-velocity-singlep (object) + "Return t when OBJECT is a list or sequence of one element." + (if (consp object) + (null (cdr object)) + (= (length object) 1))) + +(defun org-velocity-bucket-file () + "Return the proper file for Org-Velocity to search. +If `org-velocity-always-use-bucket' is t, use bucket file; +complain if missing. Otherwise, if an Org file is current, then +use it." + (let ((org-velocity-bucket + (when org-velocity-bucket (expand-file-name org-velocity-bucket))) + (buffer + (let ((buffer-file (org-velocity-buffer-file-name))) + (when buffer-file + ;; Use the target in capture buffers. + (org-find-base-buffer-visiting buffer-file))))) + (if org-velocity-always-use-bucket + (or org-velocity-bucket (error "Bucket required but not defined")) + (if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer))) + 'org-mode) + (org-velocity-buffer-file-name)) + (org-velocity-buffer-file-name) + (or org-velocity-bucket + (error "No bucket and not an Org file")))))) + +(defvar org-velocity-bucket-buffer nil) + +(defsubst org-velocity-bucket-buffer () + (or org-velocity-bucket-buffer + (find-file-noselect (org-velocity-bucket-file)))) + +(defsubst org-velocity-match-buffer () + "Return the proper buffer for Org-Velocity to display in." + (get-buffer-create org-velocity-match-buffer-name)) + +(defun org-velocity-beginning-of-headings () + "Goto the start of the first heading." + (goto-char (point-min)) + ;; If we are before the first heading we could still be at the + ;; first heading. + (or (looking-at org-velocity-heading-regexp) + (re-search-forward org-velocity-heading-regexp))) + +(defun org-velocity-make-indirect-buffer (heading) + "Make or switch to an indirect buffer visiting HEADING." + + (let* ((bucket (org-velocity-heading-buffer heading)) + (name (org-velocity-heading-name heading)) + (existing (get-buffer name))) + (if (and existing (buffer-base-buffer existing) + (equal (buffer-base-buffer existing) bucket)) + existing + (make-indirect-buffer + bucket + (generate-new-buffer-name (org-velocity-heading-name heading)))))) + +(defun org-velocity-capture () + "Record a note with `org-capture'." + (let ((org-capture-templates + org-velocity-capture-templates)) + (org-capture nil + ;; This is no longer automatically selected. + (when (org-velocity-singlep org-capture-templates) + (caar org-capture-templates))) + (if org-capture-mode (rename-buffer org-velocity-search t)))) + +(defvar org-velocity-saved-winconf nil) +(make-variable-buffer-local 'org-velocity-saved-winconf) + +(defun org-velocity-edit-entry (heading) + "Edit entry at HEADING in an indirect buffer." + (let ((winconf (current-window-configuration))) + (let ((buffer (org-velocity-make-indirect-buffer heading))) + (with-current-buffer buffer + (let ((org-inhibit-startup t)) + (org-mode)) + (setq org-velocity-saved-winconf winconf) + (goto-char (org-velocity-heading-position heading)) + (narrow-to-region (point) + (save-excursion + (org-end-of-subtree t) + (point))) + (goto-char (point-min)) + (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t)) + (pop-to-buffer buffer) + (set (make-local-variable 'header-line-format) + (format "%s Use C-c C-c to finish." + (abbreviate-file-name + (buffer-file-name + (org-velocity-heading-buffer heading)))))))) + +(defun org-velocity-dismiss () + "Save current entry and close indirect buffer." + (let ((winconf org-velocity-saved-winconf)) + (prog1 t ;Tell hook we're done. + (save-buffer) + (kill-buffer) + (when (window-configuration-p winconf) + (set-window-configuration winconf))))) + +(defun org-velocity-visit-button (button) + (run-hooks 'mouse-leave-buffer-hook) + (if org-velocity-use-search-ring + (add-to-history 'search-ring + (button-get button 'search) + search-ring-max)) + (org-velocity-edit-entry (button-get button 'match))) + +(define-button-type 'org-velocity-button + 'action #'org-velocity-visit-button) + +(defsubst org-velocity-buttonize (heading) + "Insert HEADING as a text button with no hints." + (insert-text-button + (propertize (org-velocity-heading-name heading) 'face 'link) + :type 'org-velocity-button + 'match heading + 'search org-velocity-search)) + +(defsubst org-velocity-insert-preview (heading) + (when org-velocity-show-previews + (insert-char ?\ 1) + (insert + (propertize + (org-velocity-heading-preview heading) + 'face 'shadow)))) + +(defsubst* org-velocity-present-match (&key hint match) + (with-current-buffer (org-velocity-match-buffer) + (when hint (insert "#" hint " ")) + (org-velocity-buttonize match) + (org-velocity-insert-preview match) + (newline))) + +(defun org-velocity-generic-search (search &optional hide-hints) + "Display any entry containing SEARCH." + (let ((hints org-velocity-index) matches) + (block nil + (while (and hints (re-search-forward search nil t)) + (let ((match (org-velocity-nearest-heading (point)))) + (org-velocity-present-match + :hint (unless hide-hints (car hints)) + :match match) + (push match matches)) + (setq hints (cdr hints)) + (unless (re-search-forward org-velocity-heading-regexp nil t) + (return)))) + (nreverse matches))) + +(defun* org-velocity-all-search (search &optional hide-hints max) + "Display only entries containing every word in SEARCH." + (let ((keywords (mapcar 'regexp-quote (split-string search))) + (hints org-velocity-index) + matches) + (org-map-entries + (lambda () + ;; Return if we've run out of hints. + (when (null hints) + (return-from org-velocity-all-search (nreverse matches))) + ;; Only search the subtree once. + (setq org-map-continue-from + (save-excursion + (goto-char (line-end-position)) + (if (re-search-forward org-velocity-heading-regexp nil t) + (line-end-position) + (point-max)))) + (when (loop for word in keywords + always (save-excursion + (re-search-forward + (concat "\\<" word "\\>") + org-map-continue-from t))) + (let ((match (org-velocity-nearest-heading (match-end 0)))) + (org-velocity-present-match + :hint (unless hide-hints (car hints)) + :match match) + (push match matches) + (setq hints (cdr hints)))))) + (nreverse matches))) + +(defun* org-velocity-present (search &key hide-hints) + "Buttonize matches for SEARCH in `org-velocity-match-buffer'. +If HIDE-HINTS is non-nil, display entries without indices. SEARCH +binds `org-velocity-search'. + +Return matches." + (if (and (stringp search) (not (string= "" search))) + ;; Fold case when the search string is all lowercase. + (let ((case-fold-search (equal search (downcase search))) + (truncate-partial-width-windows t)) + (with-current-buffer (org-velocity-match-buffer) + (erase-buffer) + ;; Permanent locals. + (setq cursor-type nil + truncate-lines t)) + (prog1 + (with-current-buffer (org-velocity-bucket-buffer) + (let ((inhibit-point-motion-hooks t) + (inhibit-field-text-motion t)) + (save-excursion + (org-velocity-beginning-of-headings) + (case org-velocity-search-method + (all (org-velocity-all-search search hide-hints)) + (phrase (org-velocity-generic-search + (concat "\\<" (regexp-quote search)) + hide-hints)) + (any (org-velocity-generic-search + (concat "\\<" + (regexp-opt (split-string search))) + hide-hints)) + (regexp (condition-case lossage + (org-velocity-generic-search + search hide-hints) + (invalid-regexp + (minibuffer-message "%s" lossage)))))))) + (with-current-buffer (org-velocity-match-buffer) + (goto-char (point-min))))) + (with-current-buffer (org-velocity-match-buffer) + (erase-buffer)))) + +(defun org-velocity-store-link () + "Function for `org-store-link-functions'." + (if org-velocity-search + (org-store-link-props + :search org-velocity-search))) + +(add-hook 'org-store-link-functions 'org-velocity-store-link) + +(defun* org-velocity-create (search &key ask) + "Create new heading named SEARCH. +If ASK is non-nil, ask first." + (when (or (null ask) (y-or-n-p "No match found, create? ")) + (let ((org-velocity-search search) + (org-default-notes-file (org-velocity-bucket-file)) + ;; save a stored link + org-store-link-plist) + (org-velocity-capture)) + search)) + +(defun org-velocity-engine (search) + "Display a list of headings where SEARCH occurs." + (let ((org-velocity-search search)) + (unless (or + (not (stringp search)) + (string= "" search)) ;exit on empty string + (case + (if (and org-velocity-force-new (eq last-command-event ?\C-j)) + :force + (let ((matches (org-velocity-present search))) + (cond ((null matches) :new) + ((org-velocity-singlep matches) :follow) + (t :prompt)))) + (:prompt (progn + (pop-to-buffer (org-velocity-match-buffer)) + (let ((hint (org-velocity-electric-read-hint))) + (when hint (case hint + (:edit (org-velocity-read nil search)) + (:force (org-velocity-create search)) + (otherwise (org-velocity-activate-button hint))))))) + (:new (unless (org-velocity-create search :ask t) + (org-velocity-read nil search))) + (:force (org-velocity-create search)) + (:follow (if (y-or-n-p "One match, follow? ") + (progn + (set-buffer (org-velocity-match-buffer)) + (goto-char (point-min)) + (button-activate (next-button (point)))) + (org-velocity-read nil search))))))) + +(defun org-velocity-position (item list) + "Return first position of ITEM in LIST." + (loop for elt in list + for i from 0 + when (equal elt item) + return i)) + +(defun org-velocity-activate-button (char) + "Go to button on line number associated with CHAR in `org-velocity-index'." + (goto-char (point-min)) + (forward-line (org-velocity-position char org-velocity-index)) + (goto-char + (button-start + (next-button (point)))) + (message "%s" (button-label (button-at (point)))) + (button-activate (button-at (point)))) + +(defun org-velocity-electric-undefined () + "Complain about an undefined key." + (interactive) + (message "%s" + (substitute-command-keys + "\\[org-velocity-electric-new] for new entry, +\\[org-velocity-electric-edit] to edit search, +\\[scroll-up] to scroll up, +\\[scroll-down] to scroll down, +\\[keyboard-quit] to quit.")) + (sit-for 4)) + +(defun org-velocity-electric-follow (ev) + "Follow a hint indexed by keyboard event EV." + (interactive (list last-command-event)) + (if (not (> (org-velocity-position ev org-velocity-index) + (1- (count-lines (point-min) (point-max))))) + (throw 'org-velocity-select ev) + (call-interactively 'org-velocity-electric-undefined))) + +(defun org-velocity-electric-click (ev) + "Follow hint indexed by a mouse event EV." + (interactive "e") + (throw 'org-velocity-select + (nth (1- (count-lines + (point-min) + (posn-point (event-start ev)))) + org-velocity-index))) + +(defun org-velocity-electric-edit () + "Edit the search string." + (interactive) + (throw 'org-velocity-select :edit)) + +(defun org-velocity-electric-new () + "Force a new entry." + (interactive) + (throw 'org-velocity-select :force)) + +(defvar org-velocity-electric-map + (let ((map (make-sparse-keymap))) + (define-key map [t] 'org-velocity-electric-undefined) + (loop for c in org-velocity-index + do (define-key map (char-to-string c) 'org-velocity-electric-follow)) + (define-key map "0" 'org-velocity-electric-new) + (define-key map "\C-v" 'scroll-up) + (define-key map "\M-v" 'scroll-down) + (define-key map (kbd "RET") 'org-velocity-electric-edit) + (define-key map [mouse-1] 'org-velocity-electric-click) + (define-key map [mouse-2] 'org-velocity-electric-click) + (define-key map [escape] 'keyboard-quit) + (define-key map "\C-h" 'help-command) + map)) + +(defun org-velocity-electric-read-hint () + "Read index of button electrically." + (with-current-buffer (org-velocity-match-buffer) + (use-local-map org-velocity-electric-map) + (catch 'org-velocity-select + (Electric-command-loop 'org-velocity-select "Follow: ")))) + +(defvar org-velocity-incremental-keymap + (let ((map (make-sparse-keymap))) + (define-key map [mouse-1] 'org-velocity-click-for-incremental) + (define-key map [mouse-2] 'org-velocity-click-for-incremental) + (define-key map "\C-v" 'scroll-up) + (define-key map "\M-v" 'scroll-down) + map)) + +(defun org-velocity-click-for-incremental () + "Jump out of search and select hint clicked on." + (interactive) + (let ((ev last-command-event)) + (org-velocity-activate-button + (nth (- (count-lines + (point-min) + (posn-point (event-start ev))) 2) + org-velocity-index))) + (throw 'click (current-buffer))) + +(defun org-velocity-displaying-completions-p () + "Is there a *Completions* buffer showing?" + (get-window-with-predicate + (lambda (w) + (eq (buffer-local-value 'major-mode (window-buffer w)) + 'completion-list-mode)))) + +(defun org-velocity-update () + "Display results of search without hinting. +Stop searching once there are more matches than can be displayed." + (unless (org-velocity-displaying-completions-p) + (let* ((search (org-velocity-minibuffer-contents)) + (matches (org-velocity-present search :hide-hints t))) + (cond ((null matches) + (select-window (active-minibuffer-window)) + (unless (or (null search) (string= "" search)) + (minibuffer-message "No match; RET to create"))) + ((and (org-velocity-singlep matches) + org-velocity-exit-on-match) + (throw 'click search)) + (t + (with-current-buffer (org-velocity-match-buffer) + (use-local-map org-velocity-incremental-keymap))))))) + +(defvar dabbrev--last-abbrev) + +(defun org-velocity-dabbrev-completion-list (abbrev) + "Return all dabbrev completions for ABBREV." + ;; This is based on `dabbrev-completion'. + (dabbrev--reset-global-variables) + (setq dabbrev--last-abbrev abbrev) + (dabbrev--find-all-expansions abbrev case-fold-search)) + +(defvar org-velocity-local-completion-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-completion-map) + (define-key map " " 'self-insert-command) + (define-key map [remap minibuffer-complete] 'minibuffer-complete-word) + map) + "Keymap for completion with `completing-read'.") + +(defun org-velocity-read-with-completion (prompt) + "Completing read with PROMPT." + (let ((minibuffer-local-completion-map + org-velocity-local-completion-map) + (completion-no-auto-exit t) + (crm-separator " ")) + (funcall + (case org-velocity-search-method + (phrase #'completing-read) + (any #'completing-read-multiple) + (all #'completing-read-multiple)) + prompt + (completion-table-dynamic + 'org-velocity-dabbrev-completion-list)))) + +(defun org-velocity-read-string (prompt &optional initial-input) + "Read string with PROMPT followed by INITIAL-INPUT." + ;; The use of initial inputs to the minibuffer is deprecated (see + ;; `read-from-minibuffer'), but in this case it is the user-friendly + ;; thing to do. + (minibuffer-with-setup-hook + (lexical-let ((initial-input initial-input)) + (lambda () + (and initial-input (insert initial-input)) + (goto-char (point-max)))) + (if (eq org-velocity-search-method 'regexp) + (read-regexp prompt) + (if org-velocity-use-completion + (org-velocity-read-with-completion prompt) + (read-string prompt))))) + +(defun org-velocity-incremental-read (prompt) + "Read string with PROMPT and display results incrementally." + (let ((res + (unwind-protect + (let* ((match-window (display-buffer (org-velocity-match-buffer))) + (org-velocity-index + ;; Truncate the index to the size of the buffer to be + ;; displayed. + (with-selected-window match-window + (if (> (window-height) (length org-velocity-index)) + ;; (subseq org-velocity-index 0 (window-height)) + (let ((hints (copy-sequence org-velocity-index))) + (setcdr (nthcdr (window-height) hints) nil) + hints) + org-velocity-index)))) + (catch 'click + (add-hook 'post-command-hook 'org-velocity-update) + (if (eq org-velocity-search-method 'regexp) + (read-regexp prompt) + (if org-velocity-use-completion + (org-velocity-read-with-completion prompt) + (read-string prompt))))) + (remove-hook 'post-command-hook 'org-velocity-update)))) + (if (bufferp res) (org-pop-to-buffer-same-window res) res))) + +(defun org-velocity (arg &optional search) + "Read a search string SEARCH for Org-Velocity interface. +This means that a buffer will display all headings where SEARCH +occurs, where one can be selected by a mouse click or by typing +its index. If SEARCH does not occur, then a new heading may be +created named SEARCH. + +If `org-velocity-bucket' is defined and +`org-velocity-always-use-bucket' is non-nil, then the bucket file +will be used; otherwise, this will work when called in any Org +file. Calling with ARG forces current file." + (interactive "P") + (let ((org-velocity-always-use-bucket + (if arg nil org-velocity-always-use-bucket))) + ;; complain if inappropriate + (assert (org-velocity-bucket-file)) + (let ((org-velocity-bucket-buffer + (find-file-noselect (org-velocity-bucket-file)))) + (unwind-protect + (let ((dabbrev-search-these-buffers-only + (list (org-velocity-bucket-buffer)))) + (org-velocity-engine + (if org-velocity-search-is-incremental + (org-velocity-incremental-read "Velocity search: ") + (org-velocity-read-string "Velocity search: " search)))) + (progn + (kill-buffer (org-velocity-match-buffer)) + (delete-other-windows)))))) + +(defalias 'org-velocity-read 'org-velocity) + +(provide 'org-velocity) + +;;; org-velocity.el ends here diff --git a/contrib/lisp/org-wikinodes.el b/contrib/lisp/org-wikinodes.el new file mode 100644 index 0000000..bdc3e34 --- /dev/null +++ b/contrib/lisp/org-wikinodes.el @@ -0,0 +1,340 @@ +;;; org-wikinodes.el --- Wiki-like CamelCase links to outline nodes + +;; Copyright (C) 2010-2012 Free Software Foundation, Inc. + +;; Author: Carsten Dominik <carsten at orgmode dot org> +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 7.01trans +;; +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(require 'org) +(eval-when-compile + (require 'cl)) + +(defgroup org-wikinodes nil + "Wiki-like CamelCase links words to outline nodes in Org mode." + :tag "Org WikiNodes" + :group 'org) + +(defconst org-wikinodes-camel-regexp "\\<[A-Z]+[a-z]+[A-Z]+[a-z]+[a-zA-Z]*\\>" + "Regular expression matching CamelCase words.") + +(defcustom org-wikinodes-active t + "Should CamelCase links be active in the current file?" + :group 'org-wikinodes + :type 'boolean) +(put 'org-wikinodes-active 'safe-local-variable 'booleanp) + +(defcustom org-wikinodes-scope 'file + "The scope of searches for wiki targets. +Allowed values are: + +file Search for targets in the current file only +directory Search for targets in all org files in the current directory" + :group 'org-wikinodes + :type '(choice + (const :tag "Find targets in current file" file) + (const :tag "Find targets in current directory" directory))) + +(defcustom org-wikinodes-create-targets 'query + "Non-nil means create Wiki target when following a wiki link fails. +Allowed values are: + +nil never create node, just throw an error if the target does not exist +query ask the user what to do +t create the node in the current buffer +\"file.org\" create the node in the file \"file.org\", in the same directory + +If you are using wiki links across files, you need to set `org-wikinodes-scope' +to `directory'." + :group 'org-wikinodes + :type '(choice + (const :tag "Never automatically create node" nil) + (const :tag "In current file" t) + (file :tag "In one special file\n") + (const :tag "Query the user" query))) + +;;; Link activation + +(defun org-wikinodes-activate-links (limit) + "Activate CamelCase words as links to Wiki targets." + (when org-wikinodes-active + (let (case-fold-search) + (if (re-search-forward org-wikinodes-camel-regexp limit t) + (if (equal (char-after (point-at-bol)) ?*) + (progn + ;; in heading - deactivate flyspell + (org-remove-flyspell-overlays-in (match-beginning 0) + (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + '(org-no-flyspell t)) + t) + ;; this is a wiki link + (org-remove-flyspell-overlays-in (match-beginning 0) + (match-end 0)) + (add-text-properties (match-beginning 0) (match-end 0) + (list 'mouse-face 'highlight + 'face 'org-link + 'keymap org-mouse-map + 'help-echo "Wiki Link")) + t))))) + +;;; Following links and creating non-existing target nodes + +(defun org-wikinodes-open-at-point () + "Check if the cursor is on a Wiki link and follow the link. + +This function goes into `org-open-at-point-functions'." + (and org-wikinodes-active + (not (org-at-heading-p)) + (let (case-fold-search) (org-in-regexp org-wikinodes-camel-regexp)) + (progn (org-wikinodes-follow-link (match-string 0)) t))) + +(defun org-wikinodes-follow-link (target) + "Follow a wiki link to TARGET. + +This need to be found as an exact headline match, either in the current +buffer, or in any .org file in the current directory, depending on the +variable `org-wikinodes-scope'. + +If a target headline is not found, it may be created according to the +setting of `org-wikinodes-create-targets'." + (if current-prefix-arg (org-wikinodes-clear-directory-targets-cache)) + (let ((create org-wikinodes-create-targets) + visiting buffer m pos file rpl) + (setq pos + (or (org-find-exact-headline-in-buffer target (current-buffer)) + (and (eq org-wikinodes-scope 'directory) + (setq file (org-wikinodes-which-file + target (file-name-directory (buffer-file-name)))) + (org-find-exact-headline-in-buffer + target (or (get-file-buffer file) + (find-file-noselect file)))))) + (if pos + (progn + (org-mark-ring-push (point)) + (org-goto-marker-or-bmk pos) + (move-marker pos nil)) + (when (eq create 'query) + (if (eq org-wikinodes-scope 'directory) + (progn + (message "Node \"%s\" does not exist. Should it be created? +\[RET] in this buffer [TAB] in another file [q]uit" target) + (setq rpl (read-char-exclusive)) + (cond + ((member rpl '(?\C-g ?q)) (error "Abort")) + ((equal rpl ?\C-m) (setq create t)) + ((equal rpl ?\C-i) + (setq create (file-name-nondirectory + (read-file-name "Create in file: ")))) + (t (error "Invalid selection")))) + (if (y-or-n-p (format "Create new node \"%s\" in current buffer? " + target)) + (setq create t) + (error "Abort")))) + + (cond + ((not create) + ;; We are not allowed to create the new node + (error "No match for link to \"%s\"" target)) + ((stringp create) + ;; Make new node in another file + (org-mark-ring-push (point)) + (org-pop-to-buffer-same-window (find-file-noselect create)) + (goto-char (point-max)) + (or (bolp) (newline)) + (insert "\n* " target "\n") + (backward-char 1) + (org-wikinodes-add-target-to-cache target) + (message "New Wiki target `%s' created in file \"%s\"" + target create)) + (t + ;; Make new node in current buffer + (org-mark-ring-push (point)) + (goto-char (point-max)) + (or (bolp) (newline)) + (insert "* " target "\n") + (backward-char 1) + (org-wikinodes-add-target-to-cache target) + (message "New Wiki target `%s' created in current buffer" + target)))))) + +;;; The target cache + +(defvar org-wikinodes-directory-targets-cache nil) + +(defun org-wikinodes-clear-cache-when-on-target () + "When on a headline that is a Wiki target, clear the cache." + (when (and (org-at-heading-p) + (org-in-regexp (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp)) + (org-in-regexp org-wikinodes-camel-regexp)) + (org-wikinodes-clear-directory-targets-cache) + t)) + +(defun org-wikinodes-clear-directory-targets-cache () + "Clear the cache where to find wiki targets." + (interactive) + (setq org-wikinodes-directory-targets-cache nil) + (message "Wiki target cache cleared, so that it will update when used again")) + +(defun org-wikinodes-get-targets () + "Return a list of all wiki targets in the current buffer." + (let ((re (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp)) + (case-fold-search nil) + targets) + (save-excursion + (save-restriction + (widen) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (push (org-match-string-no-properties 4) targets)))) + (nreverse targets))) + +(defun org-wikinodes-get-links-for-directory (dir) + "Return an alist that connects wiki links to files in directory DIR." + (let ((files (directory-files dir nil "\\`[^.#].*\\.org\\'")) + (org-inhibit-startup t) + target-file-alist file visiting m buffer) + (while (setq file (pop files)) + (setq visiting (org-find-base-buffer-visiting file)) + (setq buffer (or visiting (find-file-noselect file))) + (with-current-buffer buffer + (mapc + (lambda (target) + (setq target-file-alist (cons (cons target file) target-file-alist))) + (org-wikinodes-get-targets))) + (or visiting (kill-buffer buffer))) + target-file-alist)) + +(defun org-wikinodes-add-target-to-cache (target &optional file) + (setq file (or file buffer-file-name (error "No file for new wiki target"))) + (set-text-properties 0 (length target) nil target) + (let ((dir (file-name-directory (expand-file-name file))) + a) + (setq a (assoc dir org-wikinodes-directory-targets-cache)) + (if a + ;; Push the new target onto the existing list + (push (cons target (expand-file-name file)) (cdr a)) + ;; Call org-wikinodes-which-file so that the cache will be filled + (org-wikinodes-which-file target dir)))) + +(defun org-wikinodes-which-file (target &optional directory) + "Return the file for wiki headline TARGET DIRECTORY. +If there is no such wiki target, return nil." + (let* ((directory (expand-file-name (or directory default-directory))) + (founddir (assoc directory org-wikinodes-directory-targets-cache)) + (foundfile (cdr (assoc target (cdr founddir))))) + (or foundfile + (and (push (cons directory (org-wikinodes-get-links-for-directory directory)) + org-wikinodes-directory-targets-cache) + (cdr (assoc target (cdr (assoc directory + org-wikinodes-directory-targets-cache)))))))) + +;;; Exporting Wiki links + +(defvar target) +(defvar target-alist) +(defvar last-section-target) +(defvar org-export-target-aliases) +(defun org-wikinodes-set-wiki-targets-during-export () + (let ((line (buffer-substring (point-at-bol) (point-at-eol))) + (case-fold-search nil) + wtarget a) + (when (string-match (format org-complex-heading-regexp-format + org-wikinodes-camel-regexp) + line) + (setq wtarget (match-string 4 line)) + (push (cons wtarget target) target-alist) + (setq a (or (assoc last-section-target org-export-target-aliases) + (progn + (push (list last-section-target) + org-export-target-aliases) + (car org-export-target-aliases)))) + (push (caar target-alist) (cdr a))))) + +(defvar org-current-export-file) +(defun org-wikinodes-process-links-for-export () + "Process Wiki links in the export preprocess buffer. + +Try to find target matches in the wiki scope and replace CamelCase words +with working links." + (let ((re org-wikinodes-camel-regexp) + (case-fold-search nil) + link file) + (goto-char (point-min)) + (while (re-search-forward re nil t) + (org-if-unprotected-at (match-beginning 0) + (unless (save-match-data + (or (org-at-heading-p) + (org-in-regexp org-bracket-link-regexp) + (org-in-regexp org-plain-link-re) + (org-in-regexp "<<[^<>]+>>"))) + (setq link (match-string 0)) + (delete-region (match-beginning 0) (match-end 0)) + (save-match-data + (cond + ((org-find-exact-headline-in-buffer link (current-buffer)) + ;; Found in current buffer + (insert (format "[[#%s][%s]]" link link))) + ((eq org-wikinodes-scope 'file) + ;; No match in file, and other files are not allowed + (insert (format "%s" link))) + ((setq file + (and (org-string-nw-p org-current-export-file) + (org-wikinodes-which-file + link (file-name-directory org-current-export-file)))) + ;; Match in another file in the current directory + (insert (format "[[file:%s::%s][%s]]" file link link))) + (t ;; No match for this link + (insert (format "%s" link)))))))))) + +;;; Hook the WikiNode mechanism into Org + +;; `C-c C-o' should follow wiki links +(add-hook 'org-open-at-point-functions 'org-wikinodes-open-at-point) + +;; `C-c C-c' should clear the cache +(add-hook 'org-ctrl-c-ctrl-c-hook 'org-wikinodes-clear-cache-when-on-target) + +;; Make Wiki haeding create additional link names for headlines +(add-hook 'org-export-define-heading-targets-headline-hook + 'org-wikinodes-set-wiki-targets-during-export) + +;; Turn Wiki links into links the exporter will treat correctly +(add-hook 'org-export-preprocess-after-radio-targets-hook + 'org-wikinodes-process-links-for-export) + +;; Activate CamelCase words as part of Org mode font lock + +(defun org-wikinodes-add-to-font-lock-keywords () + "Add wikinode CamelCase highlighting to `org-font-lock-extra-keywords'." + (let ((m (member '(org-activate-plain-links) org-font-lock-extra-keywords))) + (if m + (setcdr m (cons '(org-wikinodes-activate-links) (cdr m))) + (message + "Failed to add wikinodes to `org-font-lock-extra-keywords'.")))) + +(add-hook 'org-font-lock-set-keywords-hook + 'org-wikinodes-add-to-font-lock-keywords) + +(provide 'org-wikinodes) + +;;; org-wikinodes.el ends here diff --git a/contrib/lisp/org2rem.el b/contrib/lisp/org2rem.el new file mode 100644 index 0000000..3052462 --- /dev/null +++ b/contrib/lisp/org2rem.el @@ -0,0 +1,651 @@ +;;; org2rem.el --- Convert org appointments into reminders + +;; Copyright (C) 2006-2012 Free Software Foundation, Inc. + +;; Author: Bastien Guerry and Shatad Pratap +;; Keywords: outlines, hypermedia, calendar, wp +;; Homepage: http://orgmode.org +;; Version: 6.09a +;; +;; This file is not part of GNU Emacs. +;; +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;;; Commentary: + +;; (require 'org2rem) +;; To export, do +;; +;; M-x org2rem-combine-agenda-files +;; +;; Then you can use reming like this: +;; +;; $ remind ~/org.rem +;; +;; If you want to use this regualrly, try in .emacs +;; +;; (add-hook 'org-mode-hook +;; (lambda() (add-hook 'after-save-hook +;; 'org-export-remind-all-agenda-files t t))) + +(require 'org) +(require 'org-agenda) +(require 'org-exp) +(eval-and-compile + (require 'cl)) + +(defgroup org2rem nil + "Options specific for Remind export of Org-mode files." + :tag "Org Export Remind" + :group 'org-export) + +(defcustom org-combined-agenda-remind-file "~/org.rem" + "The file name for the Remind file covering all agenda files. +This file is created with the command \\[org2rem-all-agenda-files]. +The file name should be absolute, the file will be overwritten without warning." + :group 'org2rem + :type 'file) + +(defcustom org-remind-combined-name "OrgMode" + "Calendar name for the combined Remind representing all agenda files." + :group 'org2rem + :type 'string) + +(defcustom org-remind-use-deadline '(event-if-not-todo todo-due) + "Contexts where Remind export should use a deadline time stamp. +This is a list with several symbols in it. Valid symbol are: + +event-if-todo Deadlines in TODO entries become calendar events. +event-if-not-todo Deadlines in non-TODO entries become calendar events. +todo-due Use deadlines in TODO entries as due-dates" + :group 'org2rem + :type '(set :greedy t + (const :tag "Deadlines in non-TODO entries become events" + event-if-not-todo) + (const :tag "Deadline in TODO entries become events" + event-if-todo) + (const :tag "Deadlines in TODO entries become due-dates" + todo-due))) + +(defcustom org-remind-use-scheduled '(todo-start) + "Contexts where Remind export should use a scheduling time stamp. +This is a list with several symbols in it. Valid symbol are: + +event-if-todo Scheduling time stamps in TODO entries become an event. +event-if-not-todo Scheduling time stamps in non-TODO entries become an event. +todo-start Scheduling time stamps in TODO entries become start date. + Some calendar applications show TODO entries only after + that date." + :group 'org2rem + :type '(set :greedy t + (const :tag + "SCHEDULED timestamps in non-TODO entries become events" + event-if-not-todo) + (const :tag "SCHEDULED timestamps in TODO entries become events" + event-if-todo) + (const :tag "SCHEDULED in TODO entries become start date" + todo-start))) + +(defcustom org-remind-categories '(local-tags category) + "Items that should be entered into the categories field. +This is a list of symbols, the following are valid: + +category The Org-mode category of the current file or tree +todo-state The todo state, if any +local-tags The tags, defined in the current line +all-tags All tags, including inherited ones." + :group 'org2rem + :type '(repeat + (choice + (const :tag "The file or tree category" category) + (const :tag "The TODO state" todo-state) + (const :tag "Tags defined in current line" local-tags) + (const :tag "All tags, including inherited ones" all-tags)))) + +(defcustom org-remind-include-todo nil + "Non-nil means export to remind files should also cover TODO items." + :group 'org2rem + :type '(choice + (const :tag "None" nil) + (const :tag "Unfinished" t) + (const :tag "All" all))) + +(defcustom org-remind-include-sexps t + "Non-nil means export to Remind files should also cover sexp entries. +These are entries like in the diary, but directly in an Org-mode file." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-deadline-over-scheduled t + "Non-nil means use deadline as target when both deadline and +scheduled present, vice-versa. Default is Non-nil." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-escape-percentage t + "Non-nil means % will be escaped, vice-versa. Default is Non-nil." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-extra-warn-days 3 + "Extra days Remind keep reminding." + :group 'org2rem + :type 'number) + +(defcustom org-remind-advanced-warn-days 3 + "Advanced days Remind start reminding." + :group 'org2rem + :type 'number) + +(defcustom org-remind-suppress-last-newline nil + "Non-nil means suppress last newline REM body. Default is nil." + :group 'org2rem + :type 'boolean) + +(defcustom org-remind-include-body 100 + "Amount of text below headline to be included in Remind export. +This is a number of characters that should maximally be included. +Properties, scheduling and clocking lines will always be removed. +The text will be inserted into the DESCRIPTION field." + :group 'org2rem + :type '(choice + (const :tag "Nothing" nil) + (const :tag "Everything" t) + (integer :tag "Max characters"))) + +(defcustom org-remind-store-UID nil + "Non-nil means store any created UIDs in properties. +The Remind standard requires that all entries have a unique identifyer. +Org will create these identifiers as needed. When this variable is non-nil, +the created UIDs will be stored in the ID property of the entry. Then the +next time this entry is exported, it will be exported with the same UID, +superceeding the previous form of it. This is essential for +synchronization services. +This variable is not turned on by default because we want to avoid creating +a property drawer in every entry if people are only playing with this feature, +or if they are only using it locally." + :group 'org2rem + :type 'boolean) + +;;;; Exporting + +;;; Remind export + +;;;###autoload +(defun org2rem-this-file () + "Export current file as an Remind file. +The Remind file will be located in the same directory as the Org-mode +file, but with extension `.rem'." + (interactive) + (org2rem nil buffer-file-name)) + +;;;###autoload +(defun org2rem-all-agenda-files () + "Export all files in `org-agenda-files' to Remind .rem files. +Each Remind file will be located in the same directory as the Org-mode +file, but with extension `.rem'." + (interactive) + (apply 'org2rem nil (org-agenda-files t))) + +;;;###autoload +(defun org2rem-combine-agenda-files () + "Export all files in `org-agenda-files' to a single combined Remind file. +The file is stored under the name `org-combined-agenda-remind-file'." + (interactive) + (apply 'org2rem t (org-agenda-files t))) + +(defun org2rem (combine &rest files) + "Create Remind files for all elements of FILES. +If COMBINE is non-nil, combine all calendar entries into a single large +file and store it under the name `org-combined-agenda-remind-file'." + (save-excursion + (org-agenda-prepare-buffers files) + (let* ((dir (org-export-directory + :ical (list :publishing-directory + org-export-publishing-directory))) + file rem-file rem-buffer category started org-agenda-new-buffers) + (and (get-buffer "*rem-tmp*") (kill-buffer "*rem-tmp*")) + (when combine + (setq rem-file + (if (file-name-absolute-p org-combined-agenda-remind-file) + org-combined-agenda-remind-file + (expand-file-name org-combined-agenda-remind-file dir)) + rem-buffer (org-get-agenda-file-buffer rem-file)) + (set-buffer rem-buffer) (erase-buffer)) + (while (setq file (pop files)) + (catch 'nextfile + (org-check-agenda-file file) + (set-buffer (org-get-agenda-file-buffer file)) + (unless combine + (setq rem-file (concat (file-name-as-directory dir) + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)) + ".rem")) + (setq rem-buffer (org-get-agenda-file-buffer rem-file)) + (with-current-buffer rem-buffer (erase-buffer))) + (setq category (or org-category + (file-name-sans-extension + (file-name-nondirectory buffer-file-name)))) + (if (symbolp category) (setq category (symbol-name category))) + (let ((standard-output rem-buffer)) + (if combine + (and (not started) (setq started t) + (org-start-remind-file org-remind-combined-name)) + (org-start-remind-file category)) + (org-print-remind-entries combine) + (when (or (and combine (not files)) (not combine)) + (org-finish-remind-file) + (set-buffer rem-buffer) + (run-hooks 'org-before-save-Remind-file-hook) + (save-buffer) + (run-hooks 'org-after-save-Remind-file-hook) + (and (boundp 'org-wait) (numberp org-wait) (sit-for org-wait)) + )))) + (org-release-buffers org-agenda-new-buffers)))) + +(defvar org-before-save-Remind-file-hook nil + "Hook run before an Remind file has been saved. +This can be used to modify the result of the export.") + +(defvar org-after-save-Remind-file-hook nil + "Hook run after an Remind file has been saved. +The Remind buffer is still current when this hook is run. +A good way to use this is to tell a desktop calenndar application to re-read +the Remind file.") + +(defvar org-agenda-default-appointment-duration) ; defined in org-agenda.el +(defun org-print-remind-entries (&optional combine) + "Print Remind entries for the current Org-mode file to `standard-output'. +When COMBINE is non nil, add the category to each line." + (require 'org-agenda) + (let ((re1 (concat org-ts-regexp "\\|<%%([^>\n]+>")) + (re2 (concat "--?-?\\(" org-ts-regexp "\\)")) + (dts (org-rem-ts-to-string + (format-time-string (cdr org-time-stamp-formats) (current-time)) + "start time:")) + hd ts ts2 state status (inc t) pos b sexp rrule + scheduledp deadlinep todo prefix due start + tmp pri categories entry location summary desc uid + remind-aw remind-ew (org-rem-ew org-remind-extra-warn-days) + (org-rem-aw org-remind-advanced-warn-days) + trigger diff-days (dos org-remind-deadline-over-scheduled) + (suppress-last-newline org-remind-suppress-last-newline) + (sexp-buffer (get-buffer-create "*rem-tmp*"))) + (org-refresh-category-properties) + (save-excursion + (goto-char (point-min)) + (while (re-search-forward re1 nil t) + (catch :skip + (org-agenda-skip) + (when (boundp 'org-remind-verify-function) + (unless (funcall org-remind-verify-function) + (outline-next-heading) + (backward-char 1) + (throw :skip nil))) + (setq pos (match-beginning 0) + ts (match-string 0) + inc t + hd (condition-case nil + (org-remind-cleanup-string + (org-get-heading)) + (error (throw :skip nil))) + summary (org-remind-cleanup-string + (org-entry-get nil "SUMMARY")) + desc (org-remind-cleanup-string + (or (org-entry-get nil "DESCRIPTION") + (and org-remind-include-body (org-get-entry))) + t org-remind-include-body) + location (org-remind-cleanup-string + (org-entry-get nil "LOCATION")) + uid (if org-remind-store-UID + (org-id-get-create) + (or (org-id-get) (org-id-new))) + categories (org-export-get-remind-categories) + deadlinep nil scheduledp nil) + (if (looking-at re2) + (progn + (goto-char (match-end 0)) + (setq ts2 (match-string 1) + inc (not (string-match "[0-9]\\{1,2\\}:[0-9][0-9]" ts2)))) + (setq tmp (buffer-substring (max (point-min) + (- pos org-ds-keyword-length)) + pos) + ts2 (if (string-match "[0-9]\\{1,2\\}:[0-9][0-9]-\\([0-9]\\{1,2\\}:[0-9][0-9]\\)" ts) + (progn + (setq inc nil) + (replace-match "\\1" t nil ts)) + ts) + deadlinep (string-match org-deadline-regexp tmp) + scheduledp (string-match org-scheduled-regexp tmp) + todo (org-get-todo-state) + ;; donep (org-entry-is-done-p) + )) + (when (and + deadlinep + (if todo + (not (memq 'event-if-todo org-remind-use-deadline)) + (not (memq 'event-if-not-todo org-remind-use-deadline)))) + (throw :skip t)) + (when (and + scheduledp + (if todo + (not (memq 'event-if-todo org-remind-use-scheduled)) + (not (memq 'event-if-not-todo org-remind-use-scheduled)))) + (throw :skip t)) + (setq prefix (if deadlinep "DEADLINE-" (if scheduledp "SCHEDULED-" "TS-"))) + (if (or (string-match org-tr-regexp hd) + (string-match org-ts-regexp hd)) + (setq hd (replace-match "" t t hd))) + (if (string-match "\\+\\([0-9]+\\)\\([dwmy]\\)>" ts) + (setq rrule ;is recurrence value. later give it good name. + (* (string-to-number + (cdr (assoc + (match-string 2 ts) + '(("d" . "1")("w" . "7") + ("m" . "0")("y" . "0"))))) + (string-to-number (match-string 1 ts)))) + (setq rrule nil)) + (setq summary (or summary hd)) + (if (string-match org-bracket-link-regexp summary) + (setq summary + (replace-match (if (match-end 3) + (match-string 3 summary) + (match-string 1 summary)) + t t summary))) + (if deadlinep (setq summary (concat "DEADLINE: " summary))) + (if scheduledp (setq summary (concat "SCHEDULED: " summary))) + (if (string-match "\\`<%%" ts) + (with-current-buffer sexp-buffer + (insert (substring ts 1 -1) " " summary "\n")) + (princ (format "\n## BEGIN:EVENT +## UID: %s +REM %s %s MSG EVENT:%s%s %s%s%% +## CATEGORIES:%s +## END:EVENT\n" + (concat prefix uid) + (org-rem-ts-to-string ts nil nil rrule) + (org-rem-ts-to-string ts2 "UNTIL " inc) + summary + (if (and desc (string-match "\\S-" desc)) + (concat "%_\\\n" desc) "") + (if (and location (string-match "\\S-" location)) + (concat "\nLOCATION: " location) "") + (if suppress-last-newline "" "%_") + categories))))) + + (when (and org-remind-include-sexps + (condition-case nil (require 'remind) (error nil)) + (fboundp 'remind-export-region)) + ;; Get all the literal sexps + (goto-char (point-min)) + (while (re-search-forward "^&?%%(" nil t) + (catch :skip + (org-agenda-skip) + (setq b (match-beginning 0)) + (goto-char (1- (match-end 0))) + (forward-sexp 1) + (end-of-line 1) + (setq sexp (buffer-substring b (point))) + (with-current-buffer sexp-buffer + (insert sexp "\n")))) + ;; (princ (org-diary-to-rem-string sexp-buffer)) + (kill-buffer sexp-buffer)) + + (when org-remind-include-todo + (setq prefix "TODO-") + (goto-char (point-min)) + (while (re-search-forward org-todo-line-regexp nil t) + (catch :skip + (org-agenda-skip) + (when (boundp 'org-remind-verify-function) + (unless (funcall org-remind-verify-function) + (outline-next-heading) + (backward-char 1) + (throw :skip nil))) + (setq state (match-string 2)) + (setq status (if (member state org-done-keywords) + "COMPLETED" "NEEDS-ACTION")) + (when (and state + (or (not (member state org-done-keywords)) + (eq org-remind-include-todo 'all)) + (not (member org-archive-tag (org-get-tags-at))) + ) + (setq hd (match-string 3) + summary (org-remind-cleanup-string + (org-entry-get nil "SUMMARY")) + desc (org-remind-cleanup-string + (or (org-entry-get nil "DESCRIPTION") + (and org-remind-include-body (org-get-entry))) + t org-remind-include-body) + location (org-remind-cleanup-string + (org-entry-get nil "LOCATION")) + due (and (member 'todo-due org-remind-use-deadline) + (org-entry-get nil "DEADLINE")) + start (and (member 'todo-start org-remind-use-scheduled) + (org-entry-get nil "SCHEDULED")) + categories (org-export-get-remind-categories) + uid (if org-remind-store-UID + (org-id-get-create) + (or (org-id-get) (org-id-new)))) + + (if (and due start) + (setq diff-days (org-rem-time-diff-days due start))) + + (setq remind-aw + (if due + (if diff-days + (if (> diff-days 0) + (if dos diff-days 0) + (if dos 0 diff-days)) + 1000))) + + (if (and (numberp org-rem-aw) (> org-rem-aw 0)) + (setq remind-aw (+ (or remind-aw 0) org-rem-aw))) + + (setq remind-ew + (if due + (if diff-days + (if (> diff-days 0) due nil) + due))) + + (setq trigger (if dos (if due due start) (if start start due))) + ;; (and trigger (setq trigger (org-rem-ts-to-string trigger nil nil 1 remind-aw))) + (if trigger + (setq trigger (concat + (format "[trigger('%s')] *%d " + (org-rem-ts-to-remind-date-type trigger) 1) + (if remind-aw (format "++%d" remind-aw))))) + (and due (setq due (org-rem-ts-to-remind-date-type due))) + (and start (setq start (org-rem-ts-to-remind-date-type start))) + (and remind-ew (setq remind-ew (org-rem-ts-to-remind-date-type remind-ew))) + + (if (string-match org-bracket-link-regexp hd) + (setq hd (replace-match (if (match-end 3) (match-string 3 hd) + (match-string 1 hd)) + t t hd))) + (if (string-match org-priority-regexp hd) + (setq pri (string-to-char (match-string 2 hd)) + hd (concat (substring hd 0 (match-beginning 1)) + (substring hd (match-end 1)))) + (setq pri org-default-priority)) + (setq pri (floor (1+ (* 8. (/ (float (- org-lowest-priority pri)) + (- org-lowest-priority org-highest-priority)))))) + + (princ (format "\n## BEGIN:TODO +## UID: %s +REM %s %s %s MSG TODO: %s%s%s%s%s%s%% +## CATEGORIES:%s +## SEQUENCE:1 +## STATUS:%s +## END:TODO\n" + (concat prefix uid) + (or trigger "") ;; dts) + (if remind-ew (format "UNTIL [trigger('%s' + %d)]" remind-ew (or org-rem-ew 0)) "") + (if pri (format "PRIORITY %d" pri) "") + (or summary hd) + (if (and desc (string-match "\\S-" desc)) + (concat "%_\\\nDESCRIPTION: " desc) "") + (if (and location (string-match "\\S-" location)) + (concat "LOCATION: " location) "") + (if start + (concat + "%_\\\n['" start "' - today()] " + "days over, for scheduled date - " + "[trigger('" start "')]") "") + (if due + (concat + "%_\\\n[today() - '" due "'] " + "days left, to deadline date - " + "[trigger('" due "')]") "") + (if suppress-last-newline "" "%_") + categories + status))))))))) + +(defun org-export-get-remind-categories () + "Get categories according to `org-remind-categories'." + (let ((cs org-remind-categories) c rtn tmp) + (while (setq c (pop cs)) + (cond + ((eq c 'category) (push (org-get-category) rtn)) + ((eq c 'todo-state) + (setq tmp (org-get-todo-state)) + (and tmp (push tmp rtn))) + ((eq c 'local-tags) + (setq rtn (append (nreverse (org-get-local-tags-at (point))) rtn))) + ((eq c 'all-tags) + (setq rtn (append (nreverse (org-get-tags-at (point))) rtn))))) + (mapconcat 'identity (nreverse rtn) ","))) + +(defun org-remind-cleanup-string (s &optional is-body maxlength) + "Take out stuff and quote what needs to be quoted. +When IS-BODY is non-nil, assume that this is the body of an item, clean up +whitespace, newlines, drawers, and timestamps, and cut it down to MAXLENGTH +characters." + (if (or (not s) (string-match "^[ \t\n]*$" s)) + nil + (when is-body + (let ((re (concat "\\(" org-drawer-regexp "\\)[^\000]*?:END:.*\n?")) + (re2 (concat "^[ \t]*" org-keyword-time-regexp ".*\n?"))) + (while (string-match re s) (setq s (replace-match "" t t s))) + (while (string-match re2 s) (setq s (replace-match "" t t s))))) + (if org-remind-escape-percentage + (let ((start 0)) + (while (string-match "\\([%]\\)" s start) + (setq start (+ (match-beginning 0) 2) + s (replace-match "\\1\\1" nil nil s))))) + + (let ((start 0)) + (while (string-match "\\([\n]\\)" s start) + (setq start (+ (match-beginning 0) 4) ;; less than 4 is not correct. + s (replace-match "%_\\\\\\1" nil nil s)))) + + (let ((start 0)) + (while (string-match "\\([[]\\)" s start) + (setq start (+ (match-beginning 0) 5) + s (replace-match (concat "\[" "\"" "\\1" "\"" "\]") nil nil s)))) + +;;; (when is-body +;;; (while (string-match "[ \t]*\n[ \t]*" s) +;;; (setq s (replace-match "%_" t t s)))) + + (setq s (org-trim s)) + (if is-body + (if maxlength + (if (and (numberp maxlength) + (> (length s) maxlength)) + (setq s (substring s 0 maxlength))))) + s)) + +(defun org-get-entry () + "Clean-up description string." + (save-excursion + (org-back-to-heading t) + (buffer-substring (point-at-bol 2) (org-end-of-subtree t)))) + +(defun org-start-remind-file (name) + "Start an Remind file by inserting the header." + (let ((user user-full-name) + (name (or name "unknown")) + (timezone (cadr (current-time-zone)))) + (princ + (format "# -*- Mode: shell-script; auto-fill-mode: nil -*- +## BEGIN: Reminders +## VERSION:2.0 +## Emacs with Org-mode +## Calendar:%s +## Created by: %s +## Timezone:%s +## Calscale:Gregorian\n" name user timezone)))) + +(defun org-finish-remind-file () + "Finish an Remind file by inserting the END statement." + (princ "\n## END:Reminders\n")) + +(defun org-rem-ts-to-remind-date-type (s) + (format-time-string + "%Y-%m-%d" + (apply 'encode-time (butlast (org-parse-time-string s) 3)))) + +;; (defun org-rem-date-type-to-string (s keyword &optional inc day-repeat day-advance-warn) +;; (if trigger +;; (setq trigger +;; (concat +;; (format "[trigger('%s')] *%d " +;; (org-rem-ts-to-remind-date-type trigger) day-repeat) +;; (if day-advance-warn (format "++%d" day-advance-warn)))))) + +;; (format-time-string "%Y" +;; (apply 'encode-time (butlast (org-parse-time-string "<2008-11-20 Thu 10:30>") 3))) + +(defun org-rem-ts-to-string (s keyword &optional inc day-repeat day-advance-warn) + "Take a time string S and convert it to Remind format. +KEYWORD is added in front, to make a complete line like DTSTART.... +When INC is non-nil, increase the hour by two (if time string contains +a time), or the day by one (if it does not contain a time)." + (let ((t1 (org-parse-time-string s 'nodefault)) + t2 fmt have-time time) + (if (and (car t1) (nth 1 t1) (nth 2 t1)) + (setq t2 t1 have-time t) + (setq t2 (org-parse-time-string s))) + (let ((s (car t2)) (mi (nth 1 t2)) (h (nth 2 t2)) + (d (nth 3 t2)) (m (nth 4 t2)) (y (nth 5 t2))) + (when inc + (if have-time + (if org-agenda-default-appointment-duration + (setq mi (+ org-agenda-default-appointment-duration mi)) + (setq h (+ 2 h))) + (setq d (1+ d)))) + (setq time (encode-time s mi h d m y))) + (setq fmt (concat + "%d %b %Y" + (if day-advance-warn (format " ++%d" day-advance-warn)) + (if day-repeat (format " *%d" day-repeat)) + (if have-time " AT %H:%M"))) + (concat keyword (format-time-string fmt time)))) + +(defun org-rem-time-diff-days (end start) + (floor (/ (apply '- (mapcar + (lambda (s) + (let* + ((t1 (org-parse-time-string s)) + (s (car t1)) (mi (nth 1 t1)) + (h (nth 2 t1)) (d (nth 3 t1)) + (m (nth 4 t1)) (y (nth 5 t1))) + (float-time (encode-time s mi h d m y)))) + (list end start))) (* 24 60 60)))) + +(provide 'org2rem) + +;;; org-exp.el ends here diff --git a/contrib/lisp/orgtbl-sqlinsert.el b/contrib/lisp/orgtbl-sqlinsert.el new file mode 100644 index 0000000..d2580d8 --- /dev/null +++ b/contrib/lisp/orgtbl-sqlinsert.el @@ -0,0 +1,116 @@ +;;; orgtbl-sqlinsert.el --- orgtbl to SQL insert statements. + +;; Copyright (C) 2008-2012 Free Software Foundation + +;; Author: Jason Riedy <jason@acm.org> +;; Keywords: org, tables, sql + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Converts an orgtbl to a sequence of SQL insertion commands. +;; Table cells are quoted and escaped very conservatively. + +;;; Code: + +(defun orgtbl-to-sqlinsert (table params) + "Convert the orgtbl-mode TABLE to SQL insert statements. +TABLE is a list, each entry either the symbol `hline' for a horizontal +separator line, or a list of fields for that line. +PARAMS is a property list of parameters that can influence the conversion. + +Names and strings are modified slightly by default. Single-ticks +are doubled as per SQL's standard mechanism. Backslashes and +dollar signs are deleted. And tildes are changed to spaces. +These modifications were chosed for use with TeX. See +ORGTBL-SQL-STRIP-AND-QUOTE. + +Supports all parameters from ORGTBL-TO-GENERIC. New to this function +are: + +:sqlname The name of the database table; defaults to the name of the + target region. + +:nowebname If not nil, used as a wrapping noweb fragment name. + +The most important parameters of ORGTBL-TO-GENERIC for SQL are: + +:splice When set to t, return only insert statements, don't wrap + them in a transaction. Default is nil. + +:tstart, :tend + The strings used to begin and commit the transaction. + +:hfmt A function that gathers the quoted header names into a + dynamically scoped variable HDRLIST. Probably should + not be changed by the user. + +The general parameters :skip and :skipcols have already been applied when +this function is called." + (let* (hdrlist + (alignment (mapconcat (lambda (x) (if x "r" "l")) + org-table-last-alignment "")) + (nowebname (plist-get params :nowebname)) + (breakvals (plist-get params :breakvals)) + (firstheader t) + (*orgtbl-default-fmt* 'orgtbl-sql-strip-and-quote) + (params2 + (list + :sqlname name + :tstart (lambda () (concat (if nowebname + (format "<<%s>>= \n" nowebname) + "") + "BEGIN TRANSACTION;")) + :tend (lambda () (concat "COMMIT;" (if nowebname "\n@ " ""))) + :hfmt (lambda (f) (progn (if firstheader (push f hdrlist)) "")) + :hlfmt (lambda (lst) (setq firstheader nil)) + :lstart (lambda () (concat "INSERT INTO " + sqlname "( " + (mapconcat 'identity (reverse hdrlist) + ", ") + " )" (if breakvals "\n" " ") + "VALUES ( ")) + :lend " );" + :sep " , " + :hline nil + :remove-nil-lines t)) + (params (org-combine-plists params2 params)) + (sqlname (plist-get params :sqlname))) + (orgtbl-to-generic table params))) + +(defun orgtbl-sql-quote (str) + "Convert single ticks to doubled single ticks and wrap in single ticks." + (concat "'" (mapconcat 'identity (split-string str "'") "''") "'")) + +(defun orgtbl-sql-strip-dollars-escapes-tildes (str) + "Strip dollarsigns and backslash escapes, replace tildes with spaces." + (mapconcat 'identity + (split-string (mapconcat 'identity + (split-string str "\\$\\|\\\\") + "") + "~") + " ")) + +(defun orgtbl-sql-strip-and-quote (str) + "Apply ORGBTL-SQL-QUOTE and ORGTBL-SQL-STRIP-DOLLARS-ESCAPES-TILDES +to sanitize STR for use in SQL statements." + (cond ((stringp str) + (orgtbl-sql-quote (orgtbl-sql-strip-dollars-escapes-tildes str))) + ((sequencep str) (mapcar 'orgtbl-sql-strip-and-quote str)) + (t nil))) + +(provide 'orgtbl-sqlinsert) + +;;; orgtbl-sqlinsert.el ends here |