diff options
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 cle |