diff options
| author | Sébastien Delafond <sdelafond@gmail.com> | 2014-07-13 13:35:27 +0200 |
|---|---|---|
| committer | Sébastien Delafond <sdelafond@gmail.com> | 2014-07-13 13:35:27 +0200 |
| commit | e32a45ed36d6000db4b39171149072d11b77af72 (patch) | |
| tree | b5f4a7d43022c08c3298e82b3e9fc50f68be660f | |
| parent | 7697fa4daf3ec84f85711a84035d8f0224afd4e3 (diff) | |
Imported Upstream version 8.0.7
239 files changed, 47412 insertions, 57861 deletions
diff --git a/.pc/.quilt_patches b/.pc/.quilt_patches deleted file mode 100644 index 6857a8d..0000000 --- a/.pc/.quilt_patches +++ /dev/null @@ -1 +0,0 @@ -debian/patches diff --git a/.pc/.quilt_series b/.pc/.quilt_series deleted file mode 100644 index c206706..0000000 --- a/.pc/.quilt_series +++ /dev/null @@ -1 +0,0 @@ -series diff --git a/.pc/.version b/.pc/.version deleted file mode 100644 index 0cfbf08..0000000 --- a/.pc/.version +++ /dev/null @@ -1 +0,0 @@ -2 diff --git a/.pc/10-shebang.patch/contrib/scripts/dir2org.zsh b/.pc/10-shebang.patch/contrib/scripts/dir2org.zsh deleted file mode 100755 index f91ff17..0000000 --- a/.pc/10-shebang.patch/contrib/scripts/dir2org.zsh +++ /dev/null @@ -1,56 +0,0 @@ -#!/usr/bin/env zsh - -# desc: -# -# Output an org compatible structure representing the filesystem from -# the point passed on the command line (or . by default). -# -# options: -# none -# -# usage: -# dir2org.zsh [DIR]... -# -# author: -# Phil Jackson (phil@shellarchive.co.uk) - -set -e - -function headline { - local depth="${1}" - local text="${2}" - - printf "%${depth}s %s" "" | tr ' ' '*' - echo " ${text}" -} - -function scan_and_populate { - local depth="${1}" - local dir="${2}" - - headline ${depth} "${dir}" - - # if there is no files in dir then just move on - [[ $(ls "${dir}" | wc -l) -eq 0 ]] && return - - (( depth += 1 )) - - for f in $(ls -d "${dir}"/*); do - if [ -d "${f}" ]; then - scan_and_populate ${depth} "${f}" - else - headline ${depth} "[[file://${f}][${${f##*/}%.*}]]" - fi - done - - (( depth -= 1 )) -} - -function main { - local scan_dir="${1:-$(pwd)}" - local depth=0 - - scan_and_populate ${depth} "${scan_dir}" -} - -main "${@}" diff --git a/.pc/30-local-mk.patch/local.mk b/.pc/30-local-mk.patch/local.mk deleted file mode 100644 index e69de29..0000000 --- a/.pc/30-local-mk.patch/local.mk +++ /dev/null diff --git a/.pc/applied-patches b/.pc/applied-patches deleted file mode 100644 index e2648c6..0000000 --- a/.pc/applied-patches +++ /dev/null @@ -1,2 +0,0 @@ -10-shebang.patch -30-local-mk.patch @@ -28,7 +28,7 @@ help helpall:: $(info make all - ditto) $(info make compile - build Org ELisp files) $(info make single - build Org ELisp files, single Emacs per source) - $(info make autoloads - create org-install.el to load Org in-place) + $(info make autoloads - create org-loaddefs.el to load Org in-place) $(info make test - build Org ELisp files and run test suite) helpall:: $(info make test-dirty - check without building first) @@ -1,9 +1,11 @@ The is a distribution of Org, a plain text notes and project planning tool for Emacs. -The version of this release is: 7.9.1 +The homepage of Org is at: + http://orgmode.org -The homepage of Org is at http://orgmode.org +The installations instructions are at: + http://orgmode.org/org.html#Installation This distribution contains: diff --git a/contrib/README b/contrib/README index 7f71ae9..3b9d9b7 100644 --- a/contrib/README +++ b/contrib/README @@ -1,34 +1,36 @@ This directory contains add-ons to Org-mode. -These contributions are not part of GNU Emacs or of the official Org-mode -package. But the git repository for Org-mode is glad to provide useful way -to distribute and develop them as long as they are distributed under a free -software license. +These contributions are not part of GNU Emacs or of the official +Org-mode package. But the git repository for Org-mode is glad to +provide useful way to distribute and develop them as long as they +are distributed under a free software license. Please put your contribution in one of these directories: -LISP (emacs-lisp code) -====================== -htmlize.el --- Convert buffer text and decorations to HTML -org2rem.el --- Convert org appointments into reminders +LISP (Emacs Lisp) +================= + +Org utils +~~~~~~~~~ org-annotate-file.el --- Annotate a file with org syntax org-bibtex-extras.el --- Extras for working with org-bibtex entries org-bookmark.el --- Links to bookmarks +org-bullets.el --- Show bullets in org-mode as UTF-8 characters org-checklist.el --- org functions for checklist handling org-choose.el --- Use TODO keywords to mark decision states org-collector.el --- Collect properties into tables -org-contacts --- Contacts management +org-colview-xemacs.el --- Column View in Org-mode, XEmacs-specific version +org-contacts.el --- Contacts management org-contribdir.el --- Dummy file to mark the org contrib Lisp directory org-depend.el --- TODO dependencies for Org-mode org-drill.el --- Self-testing with org-learn org-element.el --- Parser and applications for Org syntax org-elisp-symbol.el --- Org links to emacs-lisp symbols -org-eval.el --- The <lisp> tag, adapted from Muse org-eval-light.el --- Evaluate in-buffer code on demand -org-exp-bibtex.el --- Export citations to LaTeX and HTML -org-expiry.el --- Expiry mechanism for Org entries -org-export.el --- Generic Export Engine For Org +org-eval.el --- The <lisp> tag, adapted from Muse +org-expiry.el --- Expiry mechanism for Org entries org-export-generic.el --- Export framework for configurable backends +org-favtable.el --- Lookup table of favorite references and links org-git-link.el --- Provide org links to specific file version org-interactive-query.el --- Interactive modification of tags query org-invoice.el --- Help manage client invoices in OrgMode @@ -36,8 +38,10 @@ org-jira.el --- Add a jira:ticket protocol to Org org-learn.el --- SuperMemo's incremental learning algorithm org-mac-iCal.el --- Imports events from iCal.app to the Emacs diary org-mac-link-grabber.el --- Grab links and URLs from various Mac applications +org-mac-message.el --- Links to Apple Mail.app messages from within Org-mode org-mairix.el --- Hook mairix search into Org for different MUAs org-man.el --- Support for links to manpages in Org-mode +org-mew.el --- Support for links to Mew messages org-mime.el --- org html export for text/html MIME emails org-mtags.el --- Support for some Muse-like tags in Org-mode org-notify.el --- Notifications for Org-mode @@ -48,49 +52,48 @@ org-screen.el --- Visit screen sessions through Org-mode links org-secretary.el --- Team management with org-mode org-static-mathjax.el --- Muse-like tags in Org-mode org-sudoku.el --- Create and solve SUDOKU puzzles in Org tables -orgtbl-sqlinsert.el --- Convert Org-mode tables to SQL insertions org-toc.el --- Table of contents for Org-mode buffer org-track.el --- Keep up with Org development org-velocity.el --- something like Notational Velocity for Org +org-vm.el --- Support for links to VM messages +org-w3m.el --- Support link/copy/paste from w3m to Org-mode org-wikinodes.el --- CamelCase wiki-like links for Org +org-wl.el --- Support for links to Wanderlust messages +orgtbl-sqlinsert.el --- Convert Org-mode tables to SQL insertions +Org exporters +~~~~~~~~~~~~~ +ox-confluence.el --- Confluence Wiki exporter +ox-deck.el --- deck.js presentations exporter +ox-groff.el --- Groff exporter +ox-koma-letter.el --- KOMA Scrlttr2 exporter +ox-rss.el --- RSS 2.0 exporter +ox-s5.el --- S5 presentations exporter +ox-taskjuggler.el --- TaskJuggler exporter -EXPORT ENGINE AND BACKENDS (emacs-lisp code) -============================================ - -org-export.el --- the new export engine -org-e-latex.el --- LaTeX export backend -org-e-ascii.el --- ASCII export backend -org-e-beamer.el --- Beamer export backend -org-e-groff.el --- Groff export backend -org-e-html.el --- HTML export backend -org-e-man.el --- man pages export backend -org-e-odt.el --- ODT export backend -org-e-texinfo.el --- TeXinfo export backend -org-md.el --- MarkDown export backend - - -BABEL -===== -library-of-babel.org --- Documentation for the library of babel -langs/ob-fomus.el --- Org-babel functions for fomus evaluation -langs/ob-oz.el --- Org-babel functions for Oz evaluation - +Org Babel languages +~~~~~~~~~~~~~~~~~~~ +ob-eukleides.el --- Org-babel functions for eukleides evaluation +ob-fomus.el --- Org-babel functions for fomus evaluation +ob-julia.el --- Org-babel functions for julia evaluation +ob-mathomatic.el --- Org-babel functions for mathomatic evaluation +ob-oz.el --- Org-babel functions for Oz evaluation +ob-tcl.el --- Org-babel functions for tcl evaluation -ODT (OpenDocumentText) -====================== -README.org --- Legacy documentation for Org ODT exporter +External libraries +~~~~~~~~~~~~~~~~~~ +htmlize.el --- Convert buffer text and decorations to HTML SCRIPTS (shell, bash, etc.) =========================== - -dir2org.zsh --- Org compatible fs structure output -ditaa.jar --- ASCII to PNG converter by Stathis Sideris, GPL -org2hpda --- Generate hipster pda style printouts from Org-mode -org-docco.org --- docco side-by-side annotated code export to HTML -StartOzServer.oz --- implements the Oz-side of the Org-babel Oz interface -staticmathjax --- XULRunner application to process MathJax statically +StartOzServer.oz --- implements the Oz-side of the Org-babel Oz interface +dir2org.zsh --- Org compatible fs structure output +ditaa.jar --- ASCII to PNG converter by Stathis Sideris, GPL +org-docco.org --- docco side-by-side annotated code export to HTML +org2hpda --- Generate hipster pda style printouts from Org-mode +staticmathjax --- XULRunner application to process MathJax statically +x11idle.c --- get the idle time of your X session This directory also contains supporting files for the following packages: ob-oz.el, org-docco.org, and org-static-mathjax.el. diff --git a/contrib/babel/library-of-babel.org b/contrib/babel/library-of-babel.org deleted file mode 100644 index 0098e72..0000000 --- a/contrib/babel/library-of-babel.org +++ /dev/null @@ -1,584 +0,0 @@ -#+title: The Library of Babel -#+author: Org-mode People -#+STARTUP: hideblocks - -* Introduction - -The Library of Babel is an extensible collection of ready-made and -easily-shortcut-callable source-code blocks for handling common tasks. -Org-babel comes pre-populated with the source-code blocks located in -this file. It is possible to add source-code blocks from any org-mode -file to the library by calling =(org-babel-lob-ingest -"path/to/file.org")=. - -This file is included in worg mainly less for viewing through the web -interface, and more for contribution through the worg git repository. -If you have code snippets that you think others may find useful please -add them to this file and [[file:~/src/worg/worg-git.org::contribute-to-worg][contribute them]] to worg. - -The raw Org-mode text of this file can be downloaded at -[[repofile:contrib/babel/library-of-babel.org][library-of-babel.org]] - -* Simple - -A collection of simple utility functions: - -#+name: echo -#+begin_src emacs-lisp :var input="echo'd" - input -#+end_src - -* File I/O - -** Reading and writing files - -Read the contents of the file at =file=. The =:results vector= and -=:results scalar= header arguments can be used to read the contents of -file as either a table or a string. - -#+name: read -#+begin_src emacs-lisp :var file="" :var format="" - (if (string= format "csv") - (with-temp-buffer - (org-table-import (expand-file-name file) nil) - (org-table-to-lisp)) - (with-temp-buffer - (insert-file-contents (expand-file-name file)) - (buffer-string))) -#+end_src - -Write =data= to a file at =file=. If =data= is a list, then write it -as a table in traditional Org-mode table syntax. - -#+name: write -#+begin_src emacs-lisp :var data="" :var file="" :var ext='() - (flet ((echo (r) (if (stringp r) r (format "%S" r)))) - (with-temp-file file - (case (and (listp data) - (or ext (intern (file-name-extension file)))) - ('tsv (insert (orgtbl-to-tsv data '(:fmt echo)))) - ('csv (insert (orgtbl-to-csv data '(:fmt echo)))) - (t (org-babel-insert-result data))))) - nil -#+end_src - -** Remote files - -*** json - -Read local or remote file in [[http://www.json.org/][json]] format into emacs-lisp objects. - -#+name: json -#+begin_src emacs-lisp :var file='() :var url='() - (require 'json) - (cond - (file - (with-temp-filebuffer file - (goto-char (point-min)) - (json-read))) - (url - (require 'w3m) - (with-temp-buffer - (w3m-retrieve url) - (goto-char (point-min)) - (json-read)))) -#+end_src - -*** Google docs - -The following code blocks make use of the [[http://code.google.com/p/googlecl/][googlecl]] Google command line -tool. This tool provides functionality for accessing Google services -from the command line, and the following code blocks use /googlecl/ -for reading from and writing to Google docs with Org-mode code blocks. - -**** Read a document from Google docs - -The =google= command seems to be throwing "Moved Temporarily" errors -when trying to download textual documents, but this is working fine -for spreadsheets. - -#+name: gdoc-read -#+begin_src emacs-lisp :var title="example" :var format="csv" - (let* ((file (concat title "." format)) - (cmd (format "google docs get --format %S --title %S" format title))) - (message cmd) (message (shell-command-to-string cmd)) - (prog1 (if (string= format "csv") - (with-temp-buffer - (org-table-import (shell-quote-argument file) '(4)) - (org-table-to-lisp)) - (with-temp-buffer - (insert-file-contents (shell-quote-argument file)) - (buffer-string))) - (delete-file file))) -#+end_src - -For example, a line like the following can be used to read the -contents of a spreadsheet named =num-cells= into a table. -: #+call: gdoc-read(title="num-cells"") - -A line like the following can be used to read the contents of a -document as a string. - -: #+call: gdoc-read(title="loremi", :format "txt") - -**** Write a document to a Google docs - -Write =data= to a google document named =title=. If =data= is tabular -it will be saved to a spreadsheet, otherwise it will be saved as a -normal document. - -#+name: gdoc-write -#+begin_src emacs-lisp :var title="babel-upload" :var data=fibs(n=10) :results silent - (let* ((format (if (listp data) "csv" "txt")) - (tmp-file (make-temp-file "org-babel-google-doc" nil (concat "." format))) - (cmd (format "google docs upload --title %S %S" title tmp-file))) - (with-temp-file tmp-file - (insert - (if (listp data) - (orgtbl-to-csv - data '(:fmt (lambda (el) (if (stringp el) el (format "%S" el))))) - (if (stringp data) data (format "%S" data))))) - (message cmd) - (prog1 (shell-command-to-string cmd) (delete-file tmp-file))) -#+end_src - -example usage -: #+name: fibs -: #+begin_src emacs-lisp :var n=8 -: (flet ((fib (m) (if (< m 2) 1 (+ (fib (- m 1)) (fib (- m 2)))))) -: (mapcar (lambda (el) (list el (fib el))) (number-sequence 0 (- n 1)))) -: #+end_src -: -: #+call: gdoc-write(title="fibs", data=fibs(n=10)) - -* Plotting code - -** R - -Plot column 2 (y axis) against column 1 (x axis). Columns 3 and -beyond, if present, are ignored. - -#+name: R-plot -#+begin_src R :var data=R-plot-example-data -plot(data) -#+end_src - -#+tblname: R-plot-example-data -| 1 | 2 | -| 2 | 4 | -| 3 | 9 | -| 4 | 16 | -| 5 | 25 | - -#+call: R-plot(data=R-plot-example-data) - -#+resname: R-plot(data=R-plot-example-data) -: nil - -** Gnuplot - -* Org reference - -** Headline references - -#+name: headline -#+begin_src emacs-lisp :var headline=top :var file='() - (save-excursion - (when file (get-file-buffer file)) - (org-open-link-from-string (org-make-link-string headline)) - (save-restriction - (org-narrow-to-subtree) - (buffer-string))) -#+end_src - -#+call: headline(headline="headline references") - -* Tables - -** LaTeX Table Export - -*** booktabs - -This source block can be used to wrap a table in the latex =booktabs= -environment. The source block adds a =toprule= and =bottomrule= (so -don't use =hline= at the top or bottom of the table). The =hline= -after the header is replaced with a =midrule=. - -Note that this function bypasses the Org-mode LaTeX exporter and calls -=orgtbl-to-generic= to create the output table. This means that the -entries in the table are not translated from Org-mode to LaTeX. - -It takes the following arguments -- all but the first two are -optional. - -| arg | description | -|-------+--------------------------------------------| -| table | a reference to the table | -| align | alignment string | -| env | optional environment, default to "tabular" | -| width | optional width specification string | - -#+name: booktabs -#+begin_src emacs-lisp :var table='((:head) hline (:body)) :var align='() :var env="tabular" :var width='() :noweb yes :results latex - (flet ((to-tab (tab) - (orgtbl-to-generic - (mapcar (lambda (lis) - (if (listp lis) - (mapcar (lambda (el) - (if (stringp el) - el - (format "%S" el))) lis) - lis)) tab) - (list :lend " \\\\" :sep " & " :hline "\\hline")))) - (org-fill-template - " - \\begin{%env}%width%align - \\toprule - %table - \\bottomrule - \\end{%env}\n" - (list - (cons "env" (or env "table")) - (cons "width" (if width (format "{%s}" width) "")) - (cons "align" (if align (format "{%s}" align) "")) - (cons "table" - ;; only use \midrule if it looks like there are column headers - (if (equal 'hline (second table)) - (concat (to-tab (list (first table))) - "\n\\midrule\n" - (to-tab (cddr table))) - (to-tab table)))))) -#+end_src - -*** longtable - -This block can be used to wrap a table in the latex =longtable= -environment, it takes the following arguments -- all but the first two -are optional. - -| arg | description | -|-----------+-------------------------------------------------------------| -| table | a reference to the table | -| align | optional alignment string | -| width | optional width specification string | -| hline | the string to use as hline separator, defaults to "\\hline" | -| head | optional "head" string | -| firsthead | optional "firsthead" string | -| foot | optional "foot" string | -| lastfoot | optional "lastfoot" string | - -#+name: longtable -#+begin_src emacs-lisp :var table='((:table)) :var align='() :var width='() :var hline="\\hline" :var firsthead='() :var head='() :var foot='() :var lastfoot='() :noweb yes :results latex - (org-fill-template - " - \\begin{longtable}%width%align - %firsthead - %head - %foot - %lastfoot - - %table - \\end{longtable}\n" - (list - (cons "width" (if width (format "{%s}" width) "")) - (cons "align" (if align (format "{%s}" align) "")) - (cons "firsthead" (if firsthead (concat firsthead "\n\\endfirsthead\n") "")) - (cons "head" (if head (concat head "\n\\endhead\n") "")) - (cons "foot" (if foot (concat foot "\n\\endfoot\n") "")) - (cons "lastfoot" (if lastfoot (concat lastfoot "\n\\endlastfoot\n") "")) - (cons "table" (orgtbl-to-generic - (mapcar (lambda (lis) - (if (listp lis) - (mapcar (lambda (el) - (if (stringp el) - el - (format "%S" el))) lis) - lis)) table) - (list :lend " \\\\" :sep " & " :hline hline))))) -#+end_src - -*** booktabs-notes - -This source block builds on [[booktabs]]. It accepts two additional -arguments, both of which are optional. - -#+tblname: arguments -| arg | description | -|--------+------------------------------------------------------| -| notes | an org-mode table with footnotes | -| lspace | if non-nil, insert =addlinespace= after =bottomrule= | - -An example footnote to the =arguments= table specifies the column -span. Note the use of LaTeX, rather than Org-mode, markup. - -#+tblname: arguments-notes -| \multicolumn{2}{l}{This is a footnote to the \emph{arguments} table.} | - -#+name: booktabs-notes -#+begin_src emacs-lisp :var table='((:head) hline (:body)) :var notes='() :var align='() :var env="tabular" :var width='() :var lspace='() :noweb yes :results latex - (flet ((to-tab (tab) - (orgtbl-to-generic - (mapcar (lambda (lis) - (if (listp lis) - (mapcar (lambda (el) - (if (stringp el) - el - (format "%S" el))) lis) - lis)) tab) - (list :lend " \\\\" :sep " & " :hline "\\hline")))) - (org-fill-template - " - \\begin{%env}%width%align - \\toprule - %table - \\bottomrule%spacer - %notes - \\end{%env}\n" - (list - (cons "env" (or env "table")) - (cons "width" (if width (format "{%s}" width) "")) - (cons "align" (if align (format "{%s}" align) "")) - (cons "spacer" (if lspace "\\addlinespace" "")) - (cons "table" - ;; only use \midrule if it looks like there are column headers - (if (equal 'hline (second table)) - (concat (to-tab (list (first table))) - "\n\\midrule\n" - (to-tab (cddr table))) - (to-tab table))) - (cons "notes" (if notes (to-tab notes) "")) - ))) -#+end_src - -** Elegant lisp for transposing a matrix - -#+tblname: transpose-example -| 1 | 2 | 3 | -| 4 | 5 | 6 | - -#+name: transpose -#+begin_src emacs-lisp :var table=transpose-example - (apply #'mapcar* #'list table) -#+end_src - -#+resname: -| 1 | 4 | -| 2 | 5 | -| 3 | 6 | - -** Convert every element of a table to a string - -#+tblname: hetero-table -| 1 | 2 | 3 | -| a | b | c | - -#+name: all-to-string -#+begin_src emacs-lisp :var tbl='() - (defun all-to-string (tbl) - (if (listp tbl) - (mapcar #'all-to-string tbl) - (if (stringp tbl) - tbl - (format "%s" tbl)))) - (all-to-string tbl) -#+end_src - -#+begin_src emacs-lisp :var tbl=hetero-table - (mapcar (lambda (row) (mapcar (lambda (cell) (stringp cell)) row)) tbl) -#+end_src - -#+name: -| nil | nil | nil | -| t | t | t | - -#+begin_src emacs-lisp :var tbl=all-to-string(hetero-table) - (mapcar (lambda (row) (mapcar (lambda (cell) (stringp cell)) row)) tbl) -#+end_src - -#+name: -| t | t | t | -| t | t | t | - -* Misc - -** File-specific Version Control logging - :PROPERTIES: - :AUTHOR: Luke Crook - :END: - -This function will attempt to retrieve the entire commit log for the -file associated with the current buffer and insert this log into the -export. The function uses the Emacs VC commands to interface to the -local version control system, but has only been tested to work with -Git. 'limit' is currently unsupported. - -#+name: vc-log -#+headers: :var limit=-1 -#+headers: :var buf=(buffer-name (current-buffer)) -#+begin_src emacs-lisp - ;; Most of this code is copied from vc.el vc-print-log - (require 'vc) - (when (vc-find-backend-function - (vc-backend (buffer-file-name (get-buffer buf))) 'print-log) - (let ((limit -1) - (vc-fileset nil) - (backend nil) - (files nil)) - (with-current-buffer (get-buffer buf) - (setq vc-fileset (vc-deduce-fileset t)) ; FIXME: Why t? --Stef - (setq backend (car vc-fileset)) - (setq files (cadr vc-fileset))) - (with-temp-buffer - (let ((status (vc-call-backend - backend 'print-log files (current-buffer)))) - (when (and (processp status) ; Make sure status is a process - (= 0 (process-exit-status status))) ; which has not terminated - (while (not (eq 'exit (process-status status))) - (sit-for 1 t))) - (buffer-string))))) -#+end_src - -** Trivial python code blocks - -#+name: python-identity -#+begin_src python :var a=1 -a -#+end_src - -#+name: python-add -#+begin_src python :var a=1 :var b=2 -a + b -#+end_src - -** Arithmetic - -#+name: lob-add -#+begin_src emacs-lisp :var a=0 :var b=0 - (+ a b) -#+end_src - -#+name: lob-minus -#+begin_src emacs-lisp :var a=0 :var b=0 - (- a b) -#+end_src - -#+name: lob-times -#+begin_src emacs-lisp :var a=0 :var b=0 - (* a b) -#+end_src - -#+name: lob-div -#+begin_src emacs-lisp :var a=0 :var b=0 - (/ a b) -#+end_src - -* GANTT Charts - -The =elispgantt= source block was sent to the mailing list by Eric -Fraga. It was modified slightly by Tom Dye. - -#+name: elispgantt -#+begin_src emacs-lisp :var table=gantttest - (let ((dates "") - (entries (nthcdr 2 table)) - (milestones "") - (nmilestones 0) - (ntasks 0) - (projecttime 0) - (tasks "") - (xlength 1)) - (message "Initial: %s\n" table) - (message "Entries: %s\n" entries) - (while entries - (let ((entry (first entries))) - (if (listp entry) - (let ((id (first entry)) - (type (nth 1 entry)) - (label (nth 2 entry)) - (task (nth 3 entry)) - (dependencies (nth 4 entry)) - (start (nth 5 entry)) - (duration (nth 6 entry)) - (end (nth 7 entry)) - (alignment (nth 8 entry))) - (if (> start projecttime) (setq projecttime start)) - (if (string= type "task") - (let ((end (+ start duration)) - (textposition (+ start (/ duration 2))) - (flush "")) - (if (string= alignment "left") - (progn - (setq textposition start) - (setq flush "[left]")) - (if (string= alignment "right") - (progn - (setq textposition end) - (setq flush "[right]")))) - (setq tasks - (format "%s \\gantttask{%s}{%s}{%d}{%d}{%d}{%s}\n" - tasks label task start end textposition flush)) - (setq ntasks (+ 1 ntasks)) - (if (> end projecttime) - (setq projecttime end))) - (if (string= type "milestone") - (progn - (setq milestones - (format - "%s \\ganttmilestone{$\\begin{array}{c}\\mbox{%s}\\\\ \\mbox{%s}\\end{array}$}{%d}\n" - milestones label task start)) - (setq nmilestones (+ 1 nmilestones))) - (if (string= type "date") - (setq dates (format "%s \\ganttdateline{%s}{%d}\n" - dates label start)) - (message "Ignoring entry with type %s\n" type))))) - (message "Ignoring non-list entry %s\n" entry)) ; end if list entry - (setq entries (cdr entries)))) ; end while entries left - (format "\\pgfdeclarelayer{background} - \\pgfdeclarelayer{foreground} - \\pgfsetlayers{background,foreground} - \\renewcommand{\\ganttprojecttime}{%d} - \\renewcommand{\\ganttntasks}{%d} - \\noindent - \\begin{tikzpicture}[y=-0.75cm,x=0.75\\textwidth] - \\begin{pgfonlayer}{background} - \\draw[very thin, red!10!white] (0,1+\\ganttntasks) grid [ystep=0.75cm,xstep=1/\\ganttprojecttime] (1,0); - \\draw[\\ganttdatelinecolour] (0,0) -- (1,0); - \\draw[\\ganttdatelinecolour] (0,1+\\ganttntasks) -- (1,1+\\ganttntasks); - \\end{pgfonlayer} - %s - %s - %s - \\end{tikzpicture}" projecttime ntasks tasks milestones dates)) -#+end_src - -* Available languages - :PROPERTIES: - :AUTHOR: Bastien - :END: - -** From Org's core - -| Language | Identifier | Language | Identifier | -|------------+------------+----------------+------------| -| Asymptote | asymptote | Awk | awk | -| Emacs Calc | calc | C | C | -| C++ | C++ | Clojure | clojure | -| CSS | css | ditaa | ditaa | -| Graphviz | dot | Emacs Lisp | emacs-lisp | -| gnuplot | gnuplot | Haskell | haskell | -| Javascript | js | LaTeX | latex | -| Ledger | ledger | Lisp | lisp | -| Lilypond | lilypond | MATLAB | matlab | -| Mscgen | mscgen | Objective Caml | ocaml | -| Octave | octave | Org-mode | org | -| | | Perl | perl | -| Plantuml | plantuml | Python | python | -| R | R | Ruby | ruby | -| Sass | sass | Scheme | scheme | -| GNU Screen | screen | shell | sh | -| SQL | sql | SQLite | sqlite | - -** From Org's contrib/babel/langs - -- ob-oz.el, by Torsten Anders and Eric Schulte -- ob-fomus.el, by Torsten Anders diff --git a/contrib/lisp/htmlize.el b/contrib/lisp/htmlize.el index 516fb1d..c03d605 100644 --- a/contrib/lisp/htmlize.el +++ b/contrib/lisp/htmlize.el @@ -1,9 +1,12 @@ -;; htmlize.el -- Convert buffer text and decorations to HTML. +;;; htmlize.el --- Convert buffer text and decorations to HTML. -;; Copyright (C) 1997-2012 Hrvoje Niksic +;; Copyright (C) 1997-2013 Hrvoje Niksic ;; Author: Hrvoje Niksic <hniksic@xemacs.org> ;; Keywords: hypermedia, extensions +;; Version: 1.43 + +;; This file is not part of GNU Emacs. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -26,7 +29,7 @@ ;; 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 +;; To use it, 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' @@ -44,37 +47,43 @@ ;; 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. +;; possible to paste the generated HTML into existing HTML 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: +;; buffer or move the point. htmlize will do its best to work on +;; non-windowing Emacs sessions but the result will be limited to +;; colors supported by the terminal. + +;; htmlize aims for compatibility with Emacsen version 21 and later. +;; Please let me know if it doesn't work on the version of XEmacs or +;; GNU Emacs that you are using. The package relies on the presence +;; of CL extensions, especially for cross-emacs compatibility; please +;; don't try to remove that dependency. I see no practical problems +;; with using the full power of the CL extensions, except that one +;; might learn to like them too much. + +;; The latest version is available as a git repository at: +;; +;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.git> ;; -;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el> +;; The snapshot of the latest release can be obtained at: +;; +;; <http://fly.srk.fer.hr/~hniksic/emacs/htmlize.el.cgi> ;; ;; 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. +;; Thanks go to the many people who have sent reports and contributed +;; comments, suggestions, and fixes. They include Ron Gut, Bob +;; Weiner, Toni Drabik, Peter Breton, Ville Skytta, 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 @@ -84,48 +93,27 @@ (require 'cl) (eval-when-compile + (defvar unresolved) (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)))) + (defvar global-font-lock-mode)) + +(defconst htmlize-version "1.43") (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." + "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'. + "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\">. @@ -145,11 +133,47 @@ sheet to carry around)." :type '(choice (const css) (const inline-css) (const font)) :group 'htmlize) +(defcustom htmlize-use-images t + "Whether htmlize generates `img' for images attached to buffer contents." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-force-inline-images nil + "Non-nil means generate all images inline using data URLs. +Normally htmlize converts image descriptors with :file properties to +relative URIs, and those with :data properties to data URIs. With this +flag set, the images specified as a file name are loaded into memory and +embedded in the HTML as data URIs." + :type 'boolean + :group 'htmlize) + +(defcustom htmlize-max-alt-text 100 + "Maximum size of text to use as ALT text in images. + +Normally when htmlize encounters text covered by the `display' property +that specifies an image, it generates an `alt' attribute containing the +original text. If the text is larger than `htmlize-max-alt-text' characters, +this will not be done.") + +(defcustom htmlize-transform-image 'htmlize-default-transform-image + "Function called to modify the image descriptor. + +The function is called with the image descriptor found in the buffer and +the text the image is supposed to replace. It should return a (possibly +different) image descriptor property list or a replacement string to use +instead of of the original buffer text. + +Returning nil is the same as returning the original text." + :type 'boolean + :group 'htmlize) + (defcustom htmlize-generate-hyperlinks t - "*Non-nil means generate the hyperlinks for URLs and mail addresses. + "Non-nil means auto-generate the links from URLs and mail addresses in buffer. + 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.)" +autogenerate such links. Note that this option only turns off automatic +search for contents that looks like URLs and converting them to links. +It has no effect on whether htmlize respects the `htmlize-link' property." :type 'boolean :group 'htmlize) @@ -164,12 +188,12 @@ do your own hyperlinkification from htmlize-after-hook.)" text-decoration: underline; } " - "*The CSS style used for hyperlinks when in CSS mode." + "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. + "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 @@ -185,7 +209,7 @@ htmlize-after-hook." :group 'htmlize) (defcustom htmlize-html-charset nil - "*The charset declared by the resulting HTML documents. + "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: @@ -201,16 +225,16 @@ 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." +the buffer is in the encoding you're claiming it is in. (This is +normally achieved by using the correct file coding system for the +buffer.) If you don't understand what that means, you should probably +leave this option in its default setting." :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. +(defcustom htmlize-convert-nonascii-to-entities t + "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 @@ -231,21 +255,13 @@ which has nothing to do with the charset the page is in. For example, 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. + "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." @@ -255,7 +271,7 @@ Please note that font sizes only work with CSS-based output types." :group 'htmlize) (defcustom htmlize-css-name-prefix "" - "*The prefix used for CSS names. + "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. @@ -264,7 +280,7 @@ The string \"htmlize-\" is an example of a reasonable prefix." :group 'htmlize) (defcustom htmlize-use-rgb-txt t - "*Whether `rgb.txt' should be used to convert color names to RGB. + "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' @@ -273,7 +289,7 @@ 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'. +colors using `color-instance-rgb-components' and `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 @@ -311,89 +327,72 @@ output.") ;; 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. - +;; property regardless of whether the change occurred because of a +;; text property or an extent/overlay. (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))))) + (if prop + (next-single-char-property-change pos prop nil (or limit (point-max))) + (next-property-change pos nil (or limit (point-max))))) + (defun htmlize-next-face-change (pos &optional limit) + (htmlize-next-change pos 'face limit))) ((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. + ;; GNU Emacs 21+ (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)) + (if prop + (next-single-char-property-change pos prop nil limit) + (next-char-property-change pos limit))) + (defun htmlize-overlay-faces-at (pos) + (delq nil (mapcar (lambda (o) (overlay-get o 'face)) (overlays-at pos)))) + (defun htmlize-next-face-change (pos &optional limit) + ;; (htmlize-next-change pos 'face limit) would skip over entire + ;; overlays that specify the `face' property, even when they + ;; contain smaller text properties that also specify `face'. + ;; Emacs display engine merges those faces, and so must we. + (or limit + (setq limit (point-max))) + (let ((next-prop (next-single-property-change pos 'face nil limit)) + (overlay-faces (htmlize-overlay-faces-at pos))) + (while (progn + (setq pos (next-overlay-change pos)) + (and (< pos next-prop) + (equal overlay-faces (htmlize-overlay-faces-at pos))))) + (setq pos (min pos next-prop)) + ;; Additionally, we include the entire region that specifies the + ;; `display' property. + (when (get-char-property pos 'display) + (setq pos (next-single-char-property-change pos 'display nil limit))) 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))))) + (error "htmlize requires next-single-property-change or \ +next-single-char-property-change"))) + +(defmacro htmlize-lexlet (&rest letforms) + (declare (indent 1) (debug let)) + (if (and (boundp 'lexical-binding) + lexical-binding) + `(let ,@letforms) + ;; cl extensions have a macro implementing lexical let + `(lexical-let ,@letforms))) + +;; Simple overlay emulation for XEmacs + +(cond + (htmlize-running-xemacs + (defalias 'htmlize-make-overlay 'make-extent) + (defalias 'htmlize-overlay-put 'set-extent-property) + (defalias 'htmlize-overlay-get 'extent-property) + (defun htmlize-overlays-in (beg end) (extent-list nil beg end)) + (defalias 'htmlize-delete-overlay 'detach-extent)) + (t + (defalias 'htmlize-make-overlay 'make-overlay) + (defalias 'htmlize-overlay-put 'overlay-put) + (defalias 'htmlize-overlay-get 'overlay-get) + (defalias 'htmlize-overlays-in 'overlays-in) + (defalias 'htmlize-delete-overlay 'delete-overlay))) + ;;; Transformation of buffer text: HTML escapes, untabification, etc. @@ -419,17 +418,16 @@ output.") (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. + ;; which htmlize doesn't typically 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 +;; on 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. @@ -459,10 +457,9 @@ output.") ;; 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)) + ((encode-char char 'ucs) + ;; Must check if encode-char works for CHAR; + ;; it fails for Arabic and possibly elsewhere. (setf (gethash char htmlize-extended-character-cache) (format "&#%d;" (encode-char char 'ucs)))) (t @@ -472,63 +469,249 @@ output.") (char-to-string char))))) string ""))) +(defun htmlize-attr-escape (string) + ;; Like htmlize-protect-string, but also escapes double-quoted + ;; strings to make it usable in attribute values. + (setq string (htmlize-protect-string string)) + (if (not (string-match "\"" string)) + string + (mapconcat (lambda (char) + (if (eql char ?\") + """ + (char-to-string char))) + string ""))) + +(defsubst htmlize-concat (list) + (if (and (consp list) (null (cdr list))) + ;; Don't create a new string in the common case where the list only + ;; consists of one element. + (car list) + (apply #'concat list))) + +(defun htmlize-format-link (linkprops text) + (let ((uri (if (stringp linkprops) + linkprops + (plist-get linkprops :uri))) + (escaped-text (htmlize-protect-string text))) + (if uri + (format "<a href=\"%s\">%s</a>" (htmlize-attr-escape uri) escaped-text) + escaped-text))) + +(defun htmlize-escape-or-link (string) + ;; Escape STRING and/or add hyperlinks. STRING comes from a + ;; `display' property. + (let ((pos 0) (end (length string)) outlist) + (while (< pos end) + (let* ((link (get-char-property pos 'htmlize-link string)) + (next-link-change (next-single-property-change + pos 'htmlize-link string end)) + (chunk (substring string pos next-link-change))) + (push + (cond (link + (htmlize-format-link link chunk)) + ((get-char-property 0 'htmlize-literal chunk) + chunk) + (t + (htmlize-protect-string chunk))) + outlist) + (setq pos next-link-change))) + (htmlize-concat (nreverse outlist)))) + +(defun htmlize-display-prop-to-html (display text) + (let (desc) + (cond ((stringp display) + ;; Emacs ignores recursive display properties. + (htmlize-escape-or-link display)) + ((not (eq (car-safe display) 'image)) + (htmlize-protect-string text)) + ((null (setq desc (funcall htmlize-transform-image + (cdr display) text))) + (htmlize-escape-or-link text)) + ((stringp desc) + (htmlize-escape-or-link desc)) + (t + (htmlize-generate-image desc text))))) + +(defun htmlize-string-to-html (string) + ;; Convert the string to HTML, including images attached as + ;; `display' property and links as `htmlize-link' property. In a + ;; string without images or links, this is equivalent to + ;; `htmlize-protect-string'. + (let ((pos 0) (end (length string)) outlist) + (while (< pos end) + (let* ((display (get-char-property pos 'display string)) + (next-display-change (next-single-property-change + pos 'display string end)) + (chunk (substring string pos next-display-change))) + (push + (if display + (htmlize-display-prop-to-html display chunk) + (htmlize-escape-or-link chunk)) + outlist) + (setq pos next-display-change))) + (htmlize-concat (nreverse outlist)))) + +(defun htmlize-default-transform-image (imgprops _text) + "Default transformation of image descriptor to something usable in HTML. + +If `htmlize-use-images' is nil, the function always returns nil, meaning +use original text. Otherwise, it tries to find the image for images that +specify a file name. If `htmlize-force-inline-images' is non-nil, it also +converts the :file attribute to :data and returns the modified property +list." + (when htmlize-use-images + (when (plist-get imgprops :file) + (let ((location (plist-get (cdr (find-image (list imgprops))) :file))) + (when location + (setq imgprops (plist-put (copy-list imgprops) :file location))))) + (if htmlize-force-inline-images + (let ((location (plist-get imgprops :file)) + data) + (when location + (with-temp-buffer + (condition-case nil + (progn + (insert-file-contents-literally location) + (setq data (buffer-string))) + (error nil)))) + ;; if successful, return the new plist, otherwise return + ;; nil, which will use the original text + (and data + (plist-put (plist-put imgprops :file nil) + :data data))) + imgprops))) + +(defun htmlize-alt-text (_imgprops origtext) + (and (/= (length origtext) 0) + (<= (length origtext) htmlize-max-alt-text) + (not (string-match "[\0-\x1f]" origtext)) + origtext)) + +(defun htmlize-generate-image (imgprops origtext) + (let* ((alt-text (htmlize-alt-text imgprops origtext)) + (alt-attr (if alt-text + (format " alt=\"%s\"" (htmlize-attr-escape alt-text)) + ""))) + (cond ((plist-get imgprops :file) + ;; Try to find the image in image-load-path + (let* ((found-props (cdr (find-image (list imgprops)))) + (file (or (plist-get found-props :file) + (plist-get imgprops :file)))) + (format "<img src=\"%s\"%s />" + (htmlize-attr-escape (file-relative-name file)) + alt-attr))) + ((plist-get imgprops :data) + (format "<img src=\"data:image/%s;base64,%s\"%s />" + (or (plist-get imgprops :type) "") + (base64-encode-string (plist-get imgprops :data)) + alt-attr))))) + (defconst htmlize-ellipsis "...") (put-text-property 0 (length htmlize-ellipsis) 'htmlize-ellipsis t htmlize-ellipsis) +(defun htmlize-match-inv-spec (inv) + (member* inv buffer-invisibility-spec + :key (lambda (i) + (if (symbolp i) i (car i))))) + +(defun htmlize-decode-invisibility-spec (invisible) + ;; Return t, nil, or `ellipsis', depending on how invisible text should be inserted. + + (if (not (listp buffer-invisibility-spec)) + ;; If buffer-invisibility-spec is not a list, then all + ;; characters with non-nil `invisible' property are visible. + (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) + (htmlize-match-inv-spec invisible) + (some #'htmlize-match-inv-spec invisible)))) + (cond ((null match) t) + ((cdr-safe (car match)) 'ellipsis) + (t nil))))) + +(defun htmlize-add-before-after-strings (beg end text) + ;; Find overlays specifying before-string and after-string in [beg, + ;; pos). If any are found, splice them into TEXT and return the new + ;; text. + (let (additions) + (dolist (overlay (overlays-in beg end)) + (let ((before (overlay-get overlay 'before-string)) + (after (overlay-get overlay 'after-string))) + (when after + (push (cons (- (overlay-end overlay) beg) + after) + additions)) + (when before + (push (cons (- (overlay-start overlay) beg) + before) + additions)))) + (if additions + (let ((textlist nil) + (strpos 0)) + (dolist (add (stable-sort additions #'< :key #'car)) + (let ((addpos (car add)) + (addtext (cdr add))) + (push (substring text strpos addpos) textlist) + (push addtext textlist) + (setq strpos addpos))) + (push (substring text strpos) textlist) + (apply #'concat (nreverse textlist))) + text))) + +(defun htmlize-copy-prop (prop beg end string) + ;; Copy the specified property from the specified region of the + ;; buffer to the target string. We cannot rely on Emacs to copy the + ;; property because we want to handle properties coming from both + ;; text properties and overlays. + (let ((pos beg)) + (while (< pos end) + (let ((value (get-char-property pos prop)) + (next-change (htmlize-next-change pos prop end))) + (when value + (put-text-property (- pos beg) (- next-change beg) + prop value string)) + (setq pos next-change))))) + +(defun htmlize-get-text-with-display (beg end) + ;; Like buffer-substring-no-properties, except it copies the + ;; `display' property from the buffer, if found. + (let ((text (buffer-substring-no-properties beg end))) + (htmlize-copy-prop 'display beg end text) + (htmlize-copy-prop 'htmlize-link beg end text) + (unless htmlize-running-xemacs + (setq text (htmlize-add-before-after-strings beg end text))) + text)) + (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) + visible-list invisible show last-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))))) + next-change (htmlize-next-change pos 'invisible end) + show (htmlize-decode-invisibility-spec invisible)) (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))))) + (push (htmlize-get-text-with-display pos next-change) + visible-list)) + ((and (eq show 'ellipsis) + (not (eq last-show 'ellipsis)) + ;; Conflate successive ellipses. + (push htmlize-ellipsis visible-list)))) + (setq pos next-change last-show show)) + (htmlize-concat (nreverse visible-list)))) (defun htmlize-trim-ellipsis (text) ;; Remove htmlize-ellipses ("...") from the beginning of TEXT if it @@ -565,8 +748,13 @@ output.") (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) + ;; Expand the tab, carefully recreating the `display' + ;; property if one was on the TAB. + (let ((display (get-text-property match-pos 'display text)) + (expanded-tab (aref htmlize-tab-spaces tab-size))) + (when display + (put-text-property 0 tab-size 'display display expanded-tab)) + (push expanded-tab chunks)) (incf column tab-size) (setq chunk-start (1+ match-pos))) (t @@ -581,42 +769,64 @@ output.") ;; Push the remaining chunk. (push (substring text chunk-start) chunks)) ;; Generate the output from the available chunks. - (apply #'concat (nreverse chunks))))) + (htmlize-concat (nreverse chunks))))) + +(defun htmlize-extract-text (beg end trailing-ellipsis) + ;; Extract buffer text, sans the invisible parts. Then + ;; untabify it and escape the HTML metacharacters. + (let ((text (htmlize-buffer-substring-no-invisible beg end))) + (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-string-to-html text)) + (values text trailing-ellipsis))) (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." + "Replace every occurrence of '@' in STRING with %40. +This is used to protect mailto links without modifying their meaning." ;; Suggested by Ville Skytta. (while (string-match "@" string) - (setq string (replace-match "@" nil t string))) + (setq string (replace-match "%40" 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>>")))) +(defun htmlize-make-tmp-overlay (beg end props) + (let ((overlay (htmlize-make-overlay beg end))) + (htmlize-overlay-put overlay 'htmlize-tmp-overlay t) + (while props + (htmlize-overlay-put overlay (pop props) (pop props))) + overlay)) + +(defun htmlize-delete-tmp-overlays () + (dolist (overlay (htmlize-overlays-in (point-min) (point-max))) + (when (htmlize-overlay-get overlay 'htmlize-tmp-overlay) + (htmlize-delete-overlay overlay)))) + +(defun htmlize-make-link-overlay (beg end uri) + (htmlize-make-tmp-overlay beg end `(htmlize-link (:uri ,uri)))) -;; Tests for htmlize-make-hyperlinks: +(defun htmlize-create-auto-links () + "Add `htmlize-link' property to all mailto links in the buffer." + (save-excursion + (goto-char (point-min)) + (while (re-search-forward + "<\\(\\(mailto:\\)?\\([-=+_.a-zA-Z0-9]+@[-_.a-zA-Z0-9]+\\)\\)>" + nil t) + (let* ((address (match-string 3)) + (beg (match-beginning 0)) (end (match-end 0)) + (uri (concat "mailto:" (htmlize-despam-address address)))) + (htmlize-make-link-overlay beg end uri))) + (goto-char (point-min)) + (while (re-search-forward "<\\(\\(URL:\\)?\\([a-zA-Z]+://[^;>]+\\)\\)>" + nil t) + (htmlize-make-link-overlay + (match-beginning 0) (match-end 0) (match-string 3))))) + +;; Tests for htmlize-create-auto-links: ;; <mailto:hniksic@xemacs.org> ;; <http://fly.srk.fer.hr> @@ -625,6 +835,13 @@ without modifying their meaning." ;; <hniksic@xemacs.org> ;; <xalan-dev-sc.10148567319.hacuhiucknfgmpfnjcpg-john=doe.com@xml.apache.org> +(defun htmlize-shadow-form-feeds () + (let ((s "\n<hr />")) + (put-text-property 0 (length s) 'htmlize-literal t s) + (let ((disp `(display ,s))) + (while (re-search-forward "\n\^L" nil t) + (htmlize-make-tmp-overlay (match-beginning 0) (match-end 0) disp))))) + (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 @@ -637,15 +854,12 @@ without modifying their meaning." ;;; 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/" + `(,data-directory + "/etc/X11/rgb.txt" + "/usr/share/X11/rgb.txt" + ;; the remainder of this list really belongs in a museum + "/usr/X11R6/lib/X11/" "/usr/X11R5/lib/X11/" "/usr/lib/X11R6/X11/" "/usr/lib/X11R5/X11/" @@ -675,7 +889,7 @@ 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 + (let ((rgb-file (or rgb-file (locate-file "rgb.txt" htmlize-x-library-search-path))) (hash nil)) @@ -796,18 +1010,14 @@ If no rgb.txt file is found, return nil." (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 + (if (fboundp 'color-instance-rgb-components) (mapcar (lambda (arg) (/ arg 256)) (color-instance-rgb-components (make-color-instance color))) (mapcar (lambda (arg) (/ arg 256)) - (x-color-values color))))) + (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, @@ -866,12 +1076,37 @@ If no rgb.txt file is found, return nil." ;; Only works in Emacs 21 and later. (let ((size-list (loop - for f = face then (ignore-errors (face-attribute f :inherit)) ;????? + for f = face then (face-attribute f :inherit) until (or (not f) (eq f 'unspecified)) - for h = (ignore-errors (face-attribute f :height)) ;??????? + for h = (face-attribute f :height) collect (if (eq h 'unspecified) nil h)))) (reduce 'htmlize-merge-size (cons nil size-list)))) +(defun htmlize-face-css-name (face) + ;; Generate the css-name property for the given face. Emacs places + ;; no restrictions on the names of symbols that represent faces -- + ;; any characters may be in the name, even control chars. We try + ;; hard to beat the face name into shape, both esthetically and + ;; according to CSS1 specs. + (let ((name (downcase (symbol-name face)))) + (when (string-match "\\`font-lock-" name) + ;; font-lock-FOO-face -> 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. + (concat htmlize-css-name-prefix name))) + (defun htmlize-face-to-fstruct (face) "Convert Emacs face FACE to fstruct." (let ((fstruct (make-htmlize-fstruct @@ -879,87 +1114,53 @@ If no rgb.txt file is found, return nil." (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)) + (if 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. + (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))) + ;; GNU Emacs + (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)))) + (setf (htmlize-fstruct-css-name fstruct) (htmlize-face-css-name face)) 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))) + ;; Generate code with the following pattern: + ;; (progn + ;; (when (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)))))) + collect `(when (,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. @@ -1019,32 +1220,39 @@ If no rgb.txt file is found, return nil." (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-decode-face-prop (prop) + "Turn face property PROP into a list of face-like objects." + ;; PROP can be a symbol naming a face, a string naming such a + ;; symbol, a cons (foreground-color . COLOR) or (background-color + ;; COLOR), a property list (:attr1 val1 :attr2 val2 ...), or a list + ;; of any of those. + ;; + ;; (htmlize-decode-face-prop 'face) -> (face) + ;; (htmlize-decode-face-prop '(face1 face2)) -> (face1 face2) + ;; (htmlize-decode-face-prop '(:attr "val")) -> ((:attr "val")) + ;; (htmlize-decode-face-prop '((:attr "val") face (foreground-color "red"))) + ;; -> ((:attr "val") face (foreground-color "red")) + ;; + ;; Unrecognized atoms or non-face symbols/strings are silently + ;; stripped away. + (cond ((null prop) + nil) + ((symbolp prop) + (and (facep prop) + (list prop))) + ((stringp prop) + (and (facep (intern-soft prop)) + (list prop))) + ((atom prop) + nil) + ((and (symbolp (car prop)) + (eq ?: (aref (symbol-name (car prop)) 0))) + (list prop)) + ((or (eq (car prop) 'foreground-color) + (eq (car prop) 'background-color)) + (list prop)) + (t + (apply #'nconc (mapcar #'htmlize-decode-face-prop prop))))) (defun htmlize-make-face-map (faces) ;; Return a hash table mapping Emacs faces to htmlize's fstructs. @@ -1107,22 +1315,14 @@ property and by buffer overlays that specify `face'." (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 faces (nunion (htmlize-decode-face-prop 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)))))) + (setq faces (nunion (htmlize-decode-face-prop face-prop) + faces :test 'equal))))) faces)) ;; htmlize-faces-at-point returns the faces in use at point. The @@ -1156,10 +1356,7 @@ property and by buffer overlays that specify `face'." (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))))) + (setq all-faces (htmlize-decode-face-prop face-prop))) ;; Faces from overlays. (let ((overlays ;; Collect overlays at point that specify `face'. @@ -1189,35 +1386,26 @@ property and by buffer overlays that specify `face'." :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)))) + (setq face-prop (overlay-get overlay 'face) + list (nconc (htmlize-decode-face-prop 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. +;; htmlize supports generating HTML in several flavors, some of which +;; use CSS, and others the <font> element. We take an OO approach and +;; define "methods" that indirect to the functions that depend on +;; `htmlize-output-type'. The currently used methods are `doctype', +;; `insert-head', `body-tag', and `text-markup'. 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 @@ -1254,34 +1442,14 @@ it's called with the same value of KEY. All other times, the cached (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. - + ;; Note that the `font' output is technically invalid under this DTD + ;; because the DTD doesn't allow embedding <font> in <pre>. "<!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 + face-map ; shut up the byte-compiler "<body>") ;;; CSS based output support. @@ -1347,18 +1515,21 @@ it's called with the same value of KEY. All other times, the cached (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. +(defun htmlize-css-text-markup (fstruct-list buffer) + ;; Open the markup needed to insert text colored with FACES into + ;; BUFFER. Return the function that closes the markup. + + ;; 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))) + (htmlize-lexlet ((fstruct-list fstruct-list) (buffer buffer)) + (lambda () + (dolist (fstruct fstruct-list) + (ignore fstruct) ; shut up the byte-compiler + (princ "</span>" buffer))))) ;; `inline-css' output support. @@ -1367,7 +1538,7 @@ it's called with the same value of KEY. All other times, the cached (mapconcat #'identity (htmlize-css-specs (gethash 'default face-map)) " "))) -(defun htmlize-inline-css-insert-text (text fstruct-list buffer) +(defun htmlize-inline-css-text-markup (fstruct-list buffer) (let* ((merged (htmlize-merge-faces fstruct-list)) (style (htmlize-memoize merged @@ -1378,9 +1549,10 @@ it's called with the same value of KEY. All other times, the cached (princ "<span style=\"" buffer) (princ style buffer) (princ "\">" buffer)) - (princ text buffer) - (when style - (princ "</span>" buffer)))) + (htmlize-lexlet ((style style) (buffer buffer)) + (lambda () + (when style + (princ "</span>" buffer)))))) ;;; `font' tag based output support. @@ -1390,7 +1562,7 @@ it's called with the same value of KEY. All other times, the cached (htmlize-fstruct-foreground fstruct) (htmlize-fstruct-background fstruct)))) -(defun htmlize-font-insert-text (text fstruct-list buffer) +(defun htmlize-font-text-markup (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. @@ -1411,8 +1583,9 @@ it's called with the same value of KEY. All other times, the cached (and (htmlize-fstruct-boldp merged) "</b>") (and (htmlize-fstruct-foreground merged) "</font>")))))) (princ (car markup) buffer) - (princ text buffer) - (princ (cdr markup) buffer))) + (htmlize-lexlet ((markup markup) (buffer buffer)) + (lambda () + (princ (cdr markup) buffer))))) (defun htmlize-buffer-1 () ;; Internal function; don't call it from outside this file. Htmlize @@ -1428,122 +1601,118 @@ it's called with the same value of KEY. All other times, the cached (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))) + ;; It's important that the new buffer inherits default-directory + ;; from the current buffer. + (let ((htmlbuf (generate-new-buffer (if (buffer-file-name) + (htmlize-make-file-name + (file-name-nondirectory + (buffer-file-name))) + "*html*"))) + (completed nil)) + (unwind-protect + (let* ((buffer-faces (htmlize-faces-in-buffer)) + (face-map (htmlize-make-face-map (adjoin 'default buffer-faces))) + (places (gensym)) + (title (if (buffer-file-name) + (file-name-nondirectory (buffer-file-name)) + (buffer-name)))) + (when htmlize-generate-hyperlinks + (htmlize-create-auto-links)) + (when htmlize-replace-form-feeds + (htmlize-shadow-form-feeds)) + + ;; 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 ") + (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>") + (put places 'head-end (point-marker)) + (insert "\n ") + (put places 'body-start (point-marker)) + (insert (htmlize-method body-tag face-map) + "\n ") + (put places 'content-start (point-marker)) + (insert "<pre>\n")) + (let ((text-markup + ;; 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 'text-markup)) + ;; Declare variables used in loop body outside the loop + ;; because it's faster to establish `let' bindings only + ;; once. + next-change text face-list trailing-ellipsis + fstruct-list last-fstruct-list + (close-markup (lambda ()))) + ;; This loop traverses and reads the source buffer, appending + ;; the resulting HTML to HTMLBUF. This method is fast + ;; because: 1) it doesn't require examining the text + ;; properties char by char (htmlize-next-face-change is used + ;; to move between runs with the same face), and 2) it doesn't + ;; require frequent buffer switches, which are slow because + ;; they rebind all buffer-local vars. + (goto-char (point-min)) + (while (not (eobp)) + (setq next-change (htmlize-next-face-change (point))) + ;; 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))) + (multiple-value-setq (text trailing-ellipsis) + (htmlize-extract-text (point) next-change trailing-ellipsis)) + ;; Don't bother writing anything if there's no text (this + ;; happens in invisible regions). + (when (> (length text) 0) + ;; Open the new markup if necessary and insert the text. + (when (not (equalp fstruct-list last-fstruct-list)) + (funcall close-markup) + (setq last-fstruct-list fstruct-list + close-markup (funcall text-markup fstruct-list htmlbuf))) + (princ text htmlbuf)) + (goto-char next-change)) + + ;; We've gone through the buffer; close the markup from + ;; the last run, if any. + (funcall close-markup)) + + ;; Insert the epilog and post-process the buffer. + (with-current-buffer htmlbuf + (insert "</pre>") + (put places 'content-end (point-marker)) + (insert "\n </body>") + (put places 'body-end (point-marker)) + (insert "\n</html>\n") + (htmlize-defang-local-variables) + (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) + (symbol-plist places)) + (run-hooks 'htmlize-after-hook) + (buffer-enable-undo)) + (setq completed t) + htmlbuf) + + (when (not completed) + (kill-buffer htmlbuf)) + (htmlize-delete-tmp-overlays))))) ;; Utility functions. @@ -1766,4 +1935,9 @@ corresponding source file." (provide 'htmlize) +;; Local Variables: +;; byte-compile-warnings: (not cl-functions lexical unresolved obsolete) +;; lexical-binding: t +;; End: + ;;; htmlize.el ends here diff --git a/contrib/lisp/ob-eukleides.el b/contrib/lisp/ob-eukleides.el new file mode 100644 index 0000000..e25ed1c --- /dev/null +++ b/contrib/lisp/ob-eukleides.el @@ -0,0 +1,98 @@ +;;; ob-eukleides.el --- Org-babel functions for eukleides evaluation + +;; Copyright (C) 2010-2013 Free Software Foundation, Inc. + +;; Author: Luis Anaya +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating eukleides script. +;; +;; Inspired by Ian Yang's org-export-blocks-format-eukleides +;; http://www.emacswiki.org/emacs/org-export-blocks-format-eukleides.el + +;;; Requirements: + +;; eukleides | http://eukleides.org +;; eukleides | `org-eukleides-path' should point to the eukleides executablexs + +;;; Code: +(require 'ob) +(require 'ob-eval) + +(defvar org-babel-default-header-args:eukleides + '((:results . "file") (:exports . "results")) + "Default arguments for evaluating a eukleides source block.") + +(defcustom org-eukleides-path nil + "Path to the eukleides executable file." + :group 'org-babel + :type 'string) + +(defcustom org-eukleides-eps-to-raster nil + "Command used to convert EPS to raster. Nil for no conversion." + :group 'org-babel + :type '(choice + (repeat :tag "Shell Command Sequence" (string :tag "Shell Command")) + (const :tag "sam2p" "a=%s;b=%s;sam2p ${a} ${b}" ) + (const :tag "NetPNM" "a=%s;b=%s;pstopnm -stdout ${a} | pnmtopng > ${b}" ) + (const :tag "None" nil))) + +(defun org-babel-execute:eukleides (body params) + "Execute a block of eukleides code with org-babel. +This function is called by `org-babel-execute-src-block'." + (let* ((result-params (split-string (or (cdr (assoc :results params)) ""))) + (out-file (or (cdr (assoc :file params)) + (error "Eukleides requires a \":file\" header argument"))) + (cmdline (cdr (assoc :cmdline params))) + (in-file (org-babel-temp-file "eukleides-")) + (java (or (cdr (assoc :java params)) "")) + (cmd (if (not org-eukleides-path) + (error "`org-eukleides-path' is not set") + (concat (expand-file-name org-eukleides-path) + " -b --output=" + (org-babel-process-file-name + (concat + (file-name-sans-extension out-file) ".eps")) + " " + (org-babel-process-file-name in-file))))) + (unless (file-exists-p org-eukleides-path) + (error "Could not find eukleides at %s" org-eukleides-path)) + + (if (string= (file-name-extension out-file) "png") + (if org-eukleides-eps-to-raster + (shell-command (format org-eukleides-eps-to-raster + (concat (file-name-sans-extension out-file) ".eps") + (concat (file-name-sans-extension out-file) ".png"))) + (error "Conversion to PNG not supported. use a file with an EPS name"))) + + (with-temp-file in-file (insert body)) + (message "%s" cmd) (org-babel-eval cmd "") + nil)) ;; signal that output has already been written to file + +(defun org-babel-prep-session:eukleides (session params) + "Return an error because eukleides does not support sessions." + (error "Eukleides does not support sessions")) + +(provide 'ob-eukleides) + + + +;;; ob-eukleides.el ends here diff --git a/contrib/babel/langs/ob-fomus.el b/contrib/lisp/ob-fomus.el index f7c6ca8..58183fb 100644 --- a/contrib/babel/langs/ob-fomus.el +++ b/contrib/lisp/ob-fomus.el @@ -1,13 +1,12 @@ -;;; ob-fomus.el --- org-babel functions for fomus evaluation +;;; ob-fomus.el --- Org-babel functions for fomus evaluation -;; Copyright (C) 2011-2012 Torsten Anders +;; Copyright (C) 2011-2013 Torsten Anders ;; Author: Torsten Anders ;; Keywords: literate programming, reproducible research ;; Homepage: http://orgmode.org -;; Version: -;;; License: +;; This file is not part of GNU Emacs. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by diff --git a/contrib/lisp/ob-julia.el b/contrib/lisp/ob-julia.el new file mode 100644 index 0000000..3aed818 --- /dev/null +++ b/contrib/lisp/ob-julia.el @@ -0,0 +1,302 @@ +;;; ob-julia.el --- org-babel functions for julia code evaluation + +;; Copyright (C) 2013 G. Jay Kerns +;; Author: G. Jay Kerns, based on ob-R.el by Eric Schulte and Dan Davison + +;; This file is not part of GNU Emacs. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with 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 file provides Org-Babel support for evaluating julia code. +;; +;; See https://github.com/gjkerns/ob-julia/blob/master/ob-julia-doc.org +;; for detailed instructions on how to get started. The git repository +;; contains more documentation: git://github.com/gjkerns/ob-julia.git + +;;; Code: +(require 'ob) +(eval-when-compile (require 'cl)) + +(declare-function orgtbl-to-csv "org-table" (table params)) +(declare-function julia "ext:ess-julia" (&optional start-args)) +(declare-function inferior-ess-send-input "ext:ess-inf" ()) +(declare-function ess-make-buffer-current "ext:ess-inf" ()) +(declare-function ess-eval-buffer "ext:ess-inf" (vis)) +(declare-function org-number-sequence "org-compat" (from &optional to inc)) +(declare-function org-remove-if-not "org" (predicate seq)) + +(defconst org-babel-header-args:julia + '((width . :any) + (horizontal . :any) + (results . ((file list vector table scalar verbatim) + (raw org html latex code pp wrap) + (replace silent append prepend) + (output value graphics)))) + "julia-specific header arguments.") + +(add-to-list 'org-babel-tangle-lang-exts '("julia" . "jl")) + +(defvar org-babel-default-header-args:julia '()) + +(defcustom org-babel-julia-command inferior-julia-program-name + "Name of command to use for executing julia code." + :group 'org-babel + :version "24.4" + :package-version '(Org . "8.0") + :type 'string) + +(defvar ess-local-process-name) ; dynamically scoped +(defun org-babel-edit-prep:julia (info) + (let ((session (cdr (assoc :session (nth 2 info))))) + (when (and session (string-match "^\\*\\(.+?\\)\\*$" session)) + (save-match-data (org-babel-julia-initiate-session session nil))))) + +(defun org-babel-expand-body:julia (body params &optional graphics-file) + "Expand BODY according to PARAMS, return the expanded body." + (let ((graphics-file + (or graphics-file (org-babel-julia-graphical-output-file params)))) + (mapconcat + #'identity + ((lambda (inside) + (if graphics-file + inside + inside)) + (append (org-babel-variable-assignments:julia params) + (list body))) "\n"))) + +(defun org-babel-execute:julia (body params) + "Execute a block of julia code. +This function is called by `org-babel-execute-src-block'." + (save-excursion + (let* ((result-params (cdr (assoc :result-params params))) + (result-type (cdr (assoc :result-type params))) + (session (org-babel-julia-initiate-session + (cdr (assoc :session params)) params)) + (colnames-p (cdr (assoc :colnames params))) + (rownames-p (cdr (assoc :rownames params))) + (graphics-file (org-babel-julia-graphical-output-file params)) + (full-body (org-babel-expand-body:julia body params graphics-file)) + (result + (org-babel-julia-evaluate + session full-body result-type result-params + (or (equal "yes" colnames-p) + (org-babel-pick-name + (cdr (assoc :colname-names params)) colnames-p)) + (or (equal "yes" rownames-p) + (org-babel-pick-name + (cdr (assoc :rowname-names params)) rownames-p))))) + (if graphics-file nil result)))) + +(defun org-babel-prep-session:julia (session params) + "Prepare SESSION according to the header arguments specified in PARAMS." + (let* ((session (org-babel-julia-initiate-session session params)) + (var-lines (org-babel-variable-assignments:julia params))) + (org-babel-comint-in-buffer session + (mapc (lambda (var) + (end-of-line 1) (insert var) (comint-send-input nil t) + (org-babel-comint-wait-for-output session)) var-lines)) + session)) + +(defun org-babel-load-session:julia (session body params) + "Load BODY into SESSION." + (save-window-excursion + (let ((buffer (org-babel-prep-session:julia session params))) + (with-current-buffer buffer + (goto-char (process-mark (get-buffer-process (current-buffer)))) + (insert (org-babel-chomp body))) + buffer))) + +;; helper functions + +(defun org-babel-variable-assignments:julia (params) + "Return list of julia statements assigning the block's variables." + (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (mapcar + (lambda (pair) + (org-babel-julia-assign-elisp + (car pair) (cdr pair) + (equal "yes" (cdr (assoc :colnames params))) + (equal "yes" (cdr (assoc :rownames params))))) + (mapcar + (lambda (i) + (cons (car (nth i vars)) + (org-babel-reassemble-table + (cdr (nth i vars)) + (cdr (nth i (cdr (assoc :colname-names params)))) + (cdr (nth i (cdr (assoc :rowname-names params))))))) + (org-number-sequence 0 (1- (length vars))))))) + +(defun org-babel-julia-quote-csv-field (s) + "Quote field S for export to julia." + (if (stringp s) + (concat "\"" (mapconcat 'identity (split-string s "\"") "\"\"") "\"") + (format "%S" s))) + +(defun org-babel-julia-assign-elisp (name value colnames-p rownames-p) + "Construct julia code assigning the elisp VALUE to a variable named NAME." + (if (listp value) + (let ((max (apply #'max (mapcar #'length (org-remove-if-not + #'sequencep value)))) + (min (apply #'min (mapcar #'length (org-remove-if-not + #'sequencep value)))) + (transition-file (org-babel-temp-file "julia-import-"))) + ;; ensure VALUE has an orgtbl structure (depth of at least 2) + (unless (listp (car value)) (setq value (list value))) + (with-temp-file transition-file + (insert + (orgtbl-to-csv value '(:fmt org-babel-julia-quote-csv-field)) + "\n")) + (let ((file (org-babel-process-file-name transition-file 'noquote)) + (header (if (or (eq (nth 1 value) 'hline) colnames-p) + "TRUE" "FALSE")) + (row-names (if rownames-p "1" "NULL"))) + (if (= max min) + (format "%s = readcsv(\"%s\")" name file) + (format "%s = readcsv(\"%s\")" + name file)))) + (format "%s = %s" name (org-babel-julia-quote-csv-field value)))) + +(defvar ess-ask-for-ess-directory) ; dynamically scoped + +(defun org-babel-julia-initiate-session (session params) + "If there is not a current julia process then create one." + (unless (string= session "none") + (let ((session (or session "*julia*")) + (ess-ask-for-ess-directory + (and (and (boundp 'ess-ask-for-ess-directory) ess-ask-for-ess-directory) + (not (cdr (assoc :dir params)))))) + (if (org-babel-comint-buffer-livep session) + session + (save-window-excursion + (require 'ess) (julia) + (rename-buffer + (if (bufferp session) + (buffer-name session) + (if (stringp session) + session + (buffer-name)))) + (current-buffer)))))) + +(defun org-babel-julia-associate-session (session) + "Associate julia code buffer with a julia session. +Make SESSION be the inferior ESS process associated with the +current code buffer." + (setq ess-local-process-name + (process-name (get-buffer-process session))) + (ess-make-buffer-current)) + +(defun org-babel-julia-graphical-output-file (params) + "Name of file to which julia should send graphical output." + (and (member "graphics" (cdr (assq :result-params params))) + (cdr (assq :file params)))) + +(defvar org-babel-julia-eoe-indicator "print(\"org_babel_julia_eoe\")") +(defvar org-babel-julia-eoe-output "org_babel_julia_eoe") + +(defvar org-babel-julia-write-object-command "writecsv(\"%s\",%s)") + +;; The following was a very complicated write object command +;; The replacement needs to add error catching +;(defvar org-babel-julia-write-object-command "{function(object,transfer.file){object;invisible(if(inherits(try({tfile<-tempfile();write.table(object,file=tfile,sep=\"\\t\",na=\"nil\",row.names=%s,col.names=%s,quote=FALSE);file.rename(tfile,transfer.file)},silent=TRUE),\"try-error\")){if(!file.exists(transfer.file))file.create(transfer.file)})}}(object=%s,transfer.file=\"%s\")") + +(defun org-babel-julia-evaluate + (session body result-type result-params column-names-p row-names-p) + "Evaluate julia code in BODY." + (if session + (org-babel-julia-evaluate-session + session body result-type result-params column-names-p row-names-p) + (org-babel-julia-evaluate-external-process + body result-type result-params column-names-p row-names-p))) + +(defun org-babel-julia-evaluate-external-process + (body result-type result-params column-names-p row-names-p) + "Evaluate BODY in external julia process. +If RESULT-TYPE equals 'output then return standard output as a +string. If RESULT-TYPE equals 'value then return the value of the +last statement in BODY, as elisp." + (case result-type + (value + (let ((tmp-file (org-babel-temp-file "julia-"))) + (org-babel-eval org-babel-julia-command + (format org-babel-julia-write-object-command + (org-babel-process-file-name tmp-file 'noquote) + (format "begin\n%s\nend" body))) + (org-babel-julia-process-value-result + (org-babel-result-cond result-params + (with-temp-buffer + (insert-file-contents tmp-file) + (buffer-string)) + (org-babel-import-elisp-from-file tmp-file '(4))) + column-names-p))) + (output (org-babel-eval org-babel-julia-command body)))) + +(defun org-babel-julia-evaluate-session + (session body result-type result-params column-names-p row-names-p) + "Evaluate BODY in SESSION. +If RESULT-TYPE equals 'output then return standard output as a +string. If RESULT-TYPE equals 'value then return the value of the +last statement in BODY, as elisp." + (case result-type + (value + (with-temp-buffer + (insert (org-babel-chomp body)) + (let ((ess-local-process-name + (process-name (get-buffer-process session))) + (ess-eval-visibly-p nil)) + (ess-eval-buffer nil))) + (let ((tmp-file (org-babel-temp-file "julia-"))) + (org-babel-comint-eval-invisibly-and-wait-for-file + session tmp-file + (format org-babel-julia-write-object-command + (org-babel-process-file-name tmp-file 'noquote) "ans")) + (org-babel-julia-process-value-result + (org-babel-result-cond result-params + (with-temp-buffer + (insert-file-contents tmp-file) + (buffer-string)) + (org-babel-import-elisp-from-file tmp-file '(4))) + column-names-p))) + (output + (mapconcat + #'org-babel-chomp + (butlast + (delq nil + (mapcar + (lambda (line) (when (> (length line) 0) line)) + (mapcar + (lambda (line) ;; cleanup extra prompts left in output + (if (string-match + "^\\([ ]*[>+\\.][ ]?\\)+\\([[0-9]+\\|[ ]\\)" line) + (substring line (match-end 1)) + line)) + (org-babel-comint-with-output (session org-babel-julia-eoe-output) + (insert (mapconcat #'org-babel-chomp + (list body org-babel-julia-eoe-indicator) + "\n")) + (inferior-ess-send-input)))))) "\n")))) + +(defun org-babel-julia-process-value-result (result column-names-p) + "julia-specific processing of return value. +Insert hline if column names in output have been requested." + (if column-names-p + (cons (car result) (cons 'hline (cdr result))) + result)) + +(provide 'ob-julia) + +;;; ob-julia.el ends here diff --git a/contrib/lisp/ob-mathomatic.el b/contrib/lisp/ob-mathomatic.el new file mode 100644 index 0000000..585604e --- /dev/null +++ b/contrib/lisp/ob-mathomatic.el @@ -0,0 +1,145 @@ +;;; ob-mathomatic.el --- Org-babel functions for mathomatic evaluation + +;; Copyright (C) 2009-2013 Free Software Foundation, Inc. + +;; Author: Eric S Fraga +;; Eric Schulte +;; Luis Anaya (Mathomatic) + +;; Keywords: literate programming, reproducible research, mathomatic +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating mathomatic entries. +;; +;; This differs from most standard languages in that +;; +;; 1) there is no such thing as a "session" in mathomatic +;; +;; 2) we are adding the "cmdline" header argument + +;;; Code: +(require 'ob) + +(defvar org-babel-tangle-lang-exts) +(add-to-list 'org-babel-tangle-lang-exts '("mathomatic" . "math")) + +(defvar org-babel-default-header-args:mathomatic '()) + +(defcustom org-babel-mathomatic-command + (if (boundp 'mathomatic-command) mathomatic-command "mathomatic") + "Command used to call mathomatic on the shell." + :group 'org-babel) + +(defun org-babel-mathomatic-expand (body params) + "Expand a block of Mathomatic code according to its header arguments." + (let ((vars (mapcar #'cdr (org-babel-get-header params :var)))) + (mapconcat 'identity + (list + ;; graphic output + (let ((graphic-file (org-babel-mathomatic-graphical-output-file params))) + (if graphic-file + (cond + ((string-match ".\.eps$" graphic-file) + (format ;; Need to add command to send to file. + "set plot set terminal postscript eps\\;set output %S " + graphic-file)) + ((string-match ".\.ps$" graphic-file) + (format ;; Need to add command to send to file. + "set plot set terminal postscript\\;set output %S " + graphic-file)) + + ((string-match ".\.pic$" graphic-file) + (format ;; Need to add command to send to file. + "set plot set terminal gpic\\;set output %S " + graphic-file)) + (t + (format ;; Need to add command to send to file. + "set plot set terminal png\\;set output %S " + graphic-file))) + "")) + ;; variables + (mapconcat 'org-babel-mathomatic-var-to-mathomatic vars "\n") + ;; body + body + "") + "\n"))) + +(defun org-babel-execute:mathomatic (body params) + "Execute a block of Mathomatic entries with org-babel. This function is +called by `org-babel-execute-src-block'." + (message "executing Mathomatic source code block") + (let ((result-params (split-string (or (cdr (assoc :results params)) ""))) + (result + (let* ((cmdline (or (cdr (assoc :cmdline params)) "")) + (in-file (org-babel-temp-file "mathomatic-" ".math")) + (cmd (format "%s -t -c -q %s %s" + org-babel-mathomatic-command in-file cmdline))) + (with-temp-file in-file (insert (org-babel-mathomatic-expand body params))) + (message cmd) + ((lambda (raw) ;; " | grep -v batch | grep -v 'replaced' | sed '/^$/d' " + (mapconcat + #'identity + (delq nil + (mapcar (lambda (line) + (unless (or (string-match "batch" line) + (string-match "^rat: replaced .*$" line) + (= 0 (length line))) + line)) + (split-string raw "[\r\n]"))) "\n")) + (org-babel-eval cmd ""))))) + (if (org-babel-mathomatic-graphical-output-file params) + nil + (if (or (member "scalar" result-params) + (member "verbatim" result-params) + (member "output" result-params)) + result + (let ((tmp-file (org-babel-temp-file "mathomatic-res-"))) + (with-temp-file tmp-file (insert result)) + (org-babel-import-elisp-from-file tmp-file)))))) + +(defun org-babel-prep-session:mathomatic (session params) + (error "Mathomatic does not support sessions")) + +(defun org-babel-mathomatic-var-to-mathomatic (pair) + "Convert an elisp val into a string of mathomatic code specifying a var +of the same value." + (let ((var (car pair)) + (val (cdr pair))) + (when (symbolp val) + (setq val (symbol-name val)) + (when (= (length val) 1) + (setq val (string-to-char val)))) + (format "%s=%s" var + (org-babel-mathomatic-elisp-to-mathomatic val)))) + +(defun org-babel-mathomatic-graphical-output-file (params) + "Name of file to which mathomatic should send graphical output." + (and (member "graphics" (cdr (assq :result-params params))) + (cdr (assq :file params)))) + +(defun org-babel-mathomatic-elisp-to-mathomatic (val) + "Return a string of mathomatic code which evaluates to VAL." + (if (listp val) + (mapconcat #'org-babel-mathomatic-elisp-to-mathomatic val " ") + (format "%s" val))) + +(provide 'ob-mathomatic) + +;;; ob-mathomatic.el ends here diff --git a/contrib/babel/langs/ob-oz.el b/contrib/lisp/ob-oz.el index b778b4a..ce8e8a6 100644 --- a/contrib/babel/langs/ob-oz.el +++ b/contrib/lisp/ob-oz.el @@ -1,13 +1,13 @@ -;;; ob-oz.el --- org-babel functions for Oz evaluation +;;; ob-oz.el --- Org-babel functions for Oz evaluation -;; Copyright (C) 2009-2012 Torsten Anders and Eric Schulte +;; Copyright (C) 2009-2013 Torsten Anders and Eric Schulte -;; Author: Torsten Anders and Eric Schulte +;; Author: Torsten Anders and Eric Schulte ;; Keywords: literate programming, reproducible research ;; Homepage: http://orgmode.org ;; Version: 0.02 -;;; License: +;; This file is not part of GNU Emacs. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -26,7 +26,7 @@ ;;; Commentary: -;; Org-Babel support for evaluating Oz source code. +;; Org-Babel support for evaluating Oz source code. ;; ;; Oz code is always send to the Oz Programming Environment (OPI), the ;; Emacs mode and compiler interface for Oz programs. Therefore, only @@ -71,7 +71,7 @@ ;; arrive then in any order) I could use IDs ;; (e.g. integers). However, how do I do concurrency in Emacs Lisp, ;; and how can I define org-babel-execute:oz concurrently. -;; +;; ;; - Expressions are rarely used in Oz at the top-level, and using ;; them in documentation and Literate Programs will cause ;; confusion. Idea: hide expression from reader and instead show @@ -94,10 +94,10 @@ ;; ;; Interface to communicate with Oz. -;; (1) For statements without any results: oz-send-string +;; (1) For statements without any results: oz-send-string ;; (2) For expressions with a single result: oz-send-string-expression ;; (defined in org-babel-oz-ResultsValue.el) -;; +;; ;; oz-send-string-expression implements an additional very direct ;; communication between Org-babel and the Oz compiler. Communication @@ -128,7 +128,7 @@ "Path to the contrib/scripts directory in which StartOzServer.oz is located.") -(defvar org-babel-oz-port 6001 +(defvar org-babel-oz-port 6001 "Port for communicating with Oz compiler.") (defvar org-babel-oz-OPI-socket nil "Socket for communicating with OPI.") @@ -144,18 +144,18 @@ StartOzServer.oz is located.") (defun org-babel-oz-create-socket () (message "Create OPI socket for evaluating expressions") - ;; Start Oz directly + ;; Start Oz directly (run-oz) ;; Create socket on Oz side (after Oz was started). (oz-send-string (concat "\\insert '" org-babel-oz-server-dir "StartOzServer.oz'")) ;; Wait until socket is created before connecting to it. ;; Quick hack: wait 3 sec - ;; + ;; ;; extending time to 30 secs does not help when starting Emacs for ;; the first time (and computer does nothing else) (sit-for 3) ;; connect to OPI socket - (setq org-babel-oz-OPI-socket + (setq org-babel-oz-OPI-socket ;; Creates a socket. I/O interface of Emacs sockets as for processes. (open-network-stream "*Org-babel-OPI-socket*" nil "localhost" org-babel-oz-port)) ;; install filter @@ -166,7 +166,7 @@ StartOzServer.oz is located.") ;; oz-send-string-expression turns is into synchronous... (defun oz-send-string-expression (string &optional wait-time) "Similar to oz-send-string, oz-send-string-expression sends a string to the OPI compiler. However, string must be expression and this function returns the result of the expression (as string). oz-send-string-expression is synchronous, wait-time allows to specify a maximum wait time. After wait-time is over with no result, the function returns nil." - (if (not org-babel-oz-OPI-socket) + (if (not org-babel-oz-OPI-socket) (org-babel-oz-create-socket)) (let ((polling-delay 0.1) result) @@ -176,11 +176,11 @@ StartOzServer.oz is located.") (let ((waited 0)) (unwind-protect (progn - (while + (while ;; stop loop if org-babel-oz-collected-result \= nil or waiting time is over (not (or (not (equal org-babel-oz-collected-result nil)) (> waited wait-time))) - (progn + (progn (sit-for polling-delay) ;; (message "org-babel-oz: next polling iteration") (setq waited (+ waited polling-delay)))) @@ -253,7 +253,7 @@ called by `org-babel-execute-src-block' via multiple-value-bind." ;; (when vars ;; (with-temp-buffer ;; (insert var-lines) (write-file vars-file) -;; (oz-mode) +;; (oz-mode) ;; ;; (inferior-oz-load-file) ; ?? ;; )) ;; (current-buffer)))) @@ -262,7 +262,7 @@ called by `org-babel-execute-src-block' via multiple-value-bind." ;; TODO: testing... (simplified version of def in org-babel-prep-session:ocaml) ;; -;; BUG: does not work yet. Error: ad-Orig-error: buffer none doesn't exist or has no process +;; BUG: does not work yet. Error: ad-Orig-error: buffer none doesn't exist or has no process ;; UNUSED DEF (defun org-babel-oz-initiate-session (&optional session params) "If there is not a current inferior-process-buffer in SESSION @@ -278,12 +278,12 @@ then create. Return the initialized session." specifying a var of the same value." (if (listp var) ;; (concat "[" (mapconcat #'org-babel-oz-var-to-oz var ", ") "]") - (eval var) - (format "%s" var) ; don't preserve string quotes. + (eval var) + (format "%s" var) ; don't preserve string quotes. ;; (format "%s" var) )) -;; TODO: +;; TODO: (defun org-babel-oz-table-or-string (results) "If the results look like a table, then convert them into an Emacs-lisp table, otherwise return the results as a string." diff --git a/contrib/lisp/ob-tcl.el b/contrib/lisp/ob-tcl.el new file mode 100644 index 0000000..e8d735b --- /dev/null +++ b/contrib/lisp/ob-tcl.el @@ -0,0 +1,128 @@ +;;; ob-tcl.el --- Org-babel functions for tcl evaluation + +;; Copyright (C) 2009-2013 Free Software Foundation, Inc. + +;; Authors: Dan Davison +;; Eric Schulte +;; Luis Anaya (tcl) +;; +;; Keywords: literate programming, reproducible research +;; Homepage: http://orgmode.org + +;; This file is not part of GNU Emacs. + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Org-Babel support for evaluating tcl source code. + +;;; Code: +(require 'ob) +(require 'ob-eval) +(eval-when-compile (require 'cl)) + +(defvar org-babel-tangle-lang-exts) +(add-to-list 'org-babel-tangle-lang-exts '("tcl" . "tcl")) + +(defvar org-babel-default-header-args:tcl nil) + +(defcustom org-babel-tcl-command "tclsh" +"Name of command to use for executing Tcl code." + :group 'org-babel + :type 'string) + + +(defun org-babel-execute:tcl (body params) + "Execute a block of Tcl code with Babel. +This function is called by `org-babel-execute-src-block'." + (let* ((session (cdr (assoc :session params))) + (result-params (cdr (assoc :result-params params))) + (result-type (cdr (assoc :result-type params))) + (full-body (org-babel-expand-body:generic + body params (org-babel-variable-assignments:tcl params))) + (session (org-babel-tcl-initiate-session session))) + (org-babel-reassemble-table + (org-babel-tcl-evaluate session full-body result-type) + (org-babel-pick-name + (cdr (assoc :colname-names params)) (cdr (assoc :colnames params))) + (org-babel-pick-name + (cdr (assoc :rowname-names params)) (cdr (assoc :rownames params)))))) + +(defun org-babel-prep-session:tcl (session params) + "Prepare SESSION according to the header arguments in PARAMS." + (error "Sessions are not supported for Tcl.")) + +(defun org-babel-variable-assignments:tcl (params) + "Return list of tcl statements assigning the block's variables." + (mapcar + (lambda (pair) + (format "set %s %s" + (car pair) + (org-babel-tcl-var-to-tcl (cdr pair)))) + (mapcar #'cdr (org-babel-get-header params :var)))) + +;; helper functions + +(defun org-babel-tcl-var-to-tcl (var) + "Convert an elisp value to a tcl variable. +The elisp value, VAR, is converted to a string of tcl source code +specifying a var of the same value." + (if (listp var) + (concat "{" (mapconcat #'org-babel-tcl-var-to-tcl var " ") "}") + (format "%s" var))) + +(defvar org-babel-tcl-buffers '(:default . nil)) + +(defun org-babel-tcl-initiate-session (&optional session params) + "Return nil because sessions are not supported by tcl." +nil) + +(defvar org-babel-tcl-wrapper-method + " +proc main {} { + %s +} + +set r [eval main] +set o [open \"%s\" \"w\"]; +puts $o $r +flush $o +close $o + +") + +(defvar org-babel-tcl-pp-wrapper-method + nil) + +(defun org-babel-tcl-evaluate (session body &optional result-type) + "Pass BODY to the Tcl process in SESSION. +If RESULT-TYPE equals 'output then return a list of the outputs +of the statements in BODY, if RESULT-TYPE equals 'value then +return the value of the last statement in BODY, as elisp." + (when session (error "Sessions are not supported for Tcl.")) + (case result-type + (output (org-babel-eval org-babel-tcl-command body)) + (value (let ((tmp-file (org-babel-temp-file "tcl-"))) + (org-babel-eval + org-babel-tcl-command + (format org-babel-tcl-wrapper-method body + (org-babel-process-file-name tmp-file 'noquote))) + (org-babel-eval-read-file tmp-file))))) + +(provide 'ob-tcl) + + + +;;; ob-tcl.el ends here diff --git a/contrib/lisp/org-annotate-file.el b/contrib/lisp/org-annotate-file.el index 55e5a32..bdb9acb 100644 --- a/contrib/lisp/org-annotate-file.el +++ b/contrib/lisp/org-annotate-file.el @@ -1,6 +1,6 @@ ;;; org-annotate-file.el --- Annotate a file with org syntax -;; Copyright (C) 2008-2012 Philip Jackson +;; Copyright (C) 2008-2013 Philip Jackson ;; Author: Philip Jackson <phil@shellarchive.co.uk> ;; Version: 0.2 diff --git a/contrib/lisp/org-bibtex-extras.el b/contrib/lisp/org-bibtex-extras.el index 8424e62..93c97a9 100644 --- a/contrib/lisp/org-bibtex-extras.el +++ b/contrib/lisp/org-bibtex-extras.el @@ -1,6 +1,6 @@ ;;; org-bibtex-extras --- extras for working with org-bibtex entries -;; Copyright (C) 2008-2012 Free Software Foundation, Inc. +;; Copyright (C) 2008-2013 Free Software Foundation, Inc. ;; Author: Eric Schulte <eric dot schulte at gmx dot com> ;; Keywords: outlines, hypermedia, bibtex, d3 @@ -9,12 +9,12 @@ ;; This file is not yet part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. -;; GNU Emacs is distributed in the hope that it will be useful, +;; 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. @@ -78,7 +78,7 @@ For example, to point to your `obe-bibtex-file' use the following. (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)) + (push (org-no-properties (match-string 1)) obe-citations)) obe-citations))) @@ -111,7 +111,7 @@ For example, to point to your `obe-bibtex-file' use the following. (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))) + (:title . ,(org-no-properties (org-get-heading 1 1))) (:journal . ,(org-entry-get pt "JOURNAL"))))))) (defun obe-meta-to-json (meta &optional fields) diff --git a/contrib/lisp/org-bookmark.el b/contrib/lisp/org-bookmark.el index 56129d2..44588b6 100644 --- a/contrib/lisp/org-bookmark.el +++ b/contrib/lisp/org-bookmark.el @@ -1,5 +1,5 @@ ;;; org-bookmark.el - Support for links to bookmark -;; Copyright (C) 2008-2012 Free Software Foundation, Inc. +;; Copyright (C) 2008-2013 Free Software Foundation, Inc. ;; ;; Author: Tokuya Kameshima <kames AT fa2.so-net.ne.jp> ;; Version: 1.0 @@ -12,7 +12,7 @@ ;; 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, +;; 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. @@ -80,7 +80,7 @@ Otherwise prompt the user for the right bookmark to use." (car bmks) (completing-read "Bookmark: " bmks nil t nil nil (car bmks)))))) (if bookmark - (org-store-link-props :link (contact "bookmark:" bookmark) + (org-store-link-props :link (concat "bookmark:" bookmark) :description bookmark)))) (provide 'org-bookmark) diff --git a/contrib/lisp/org-bullets.el b/contrib/lisp/org-bullets.el new file mode 100644 index 0000000..2951bf8 --- /dev/null +++ b/contrib/lisp/org-bullets.el @@ -0,0 +1,122 @@ +;;; org-bullets.el --- Show bullets in org-mode as UTF-8 characters +;; Version: 0.2.2 +;; Author: sabof +;; URL: https://github.com/sabof/org-bullets + +;; This file is NOT part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or +;; modify it under the terms of the GNU General Public License as +;; published by the Free Software Foundation; either version 3, or (at +;; your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, but +;; WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program ; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Commentary: + +;; The project is hosted at https://github.com/sabof/org-bullets +;; The latest version, and all the relevant information can be found there. + +;;; Code: + +(eval-when-compile (require 'cl)) + +(defgroup org-bullets nil + "Display bullets as UTF-8 characters." + :group 'org-appearance) + +;; A nice collection of unicode bullets: +;; http://nadeausoftware.com/articles/2007/11/latency_friendly_customized_bullets_using_unicode_characters +(defcustom org-bullets-bullet-list + '(;;; Large + "◉" + "○" + "✸" + "✿" + ;; ♥ ● ◇ ✚ ✜ ☯ ◆ ♠ ♣ ♦ ☢ ❀ ◆ ◖ ▶ + ;;; Small + ;; ► • ★ ▸ + ) + "This variable contains the list of bullets. +It can contain any number of one-character strings. +For levels beyond the size of the list, the stars will be +displayed using the first items again." + :group 'org-bullets + :type '(repeat (string :tag "Bullet character"))) + +(defcustom org-bullets-face-name nil + "Allows to override `org-mode' bullets face. +If set to a name of a face, that face will be used. +Otherwise the face of the heading level will be used." + :group 'org-bullets + :type 'symbol) + +(defvar org-bullets-bullet-map + '(keymap + (mouse-1 . org-cycle) + (mouse-2 . (lambda (e) + (interactive "e") + (mouse-set-point e) + (org-cycle)))) + "Mouse events for bullets. +If this is undesirable, one can remove them with + +\(setcdr org-bullets-bullet-map nil\)") + +(defun org-bullets-level-char (level) + "Return a character corresponding to LEVEL." + (string-to-char + (nth (mod (1- level) + (length org-bullets-bullet-list)) + org-bullets-bullet-list))) + +;;;###autoload +(define-minor-mode org-bullets-mode + "UTF-8 bullets for `org-mode'." + nil nil nil + (let* ((keyword + `((,org-outline-regexp-bol + (0 (let (( level (- (match-end 0) (match-beginning 0) 1))) + (compose-region (- (match-end 0) 2) + (- (match-end 0) 1) + (org-bullets-level-char level)) + (when (facep org-bullets-face-name) + (put-text-property (- (match-end 0) 2) + (- (match-end 0) 1) + 'face + org-bullets-face-name)) + (put-text-property (match-beginning 0) + (- (match-end 0) 2) + 'face (list :foreground + (face-attribute + 'default :background))) + (put-text-property (match-beginning 0) + (match-end 0) + 'keymap + org-bullets-bullet-map) + nil)))))) + (if org-bullets-mode + (progn (font-lock-add-keywords nil keyword) + (font-lock-fontify-buffer)) + (save-excursion + (goto-char (point-min)) + (font-lock-remove-keywords nil keyword) + (while (re-search-forward org-outline-regexp-bol nil t) + (decompose-region (match-beginning 0) (match-end 0))) + (font-lock-fontify-buffer))))) + +(provide 'org-bullets) + +;; Local Variables: +;; coding: utf-8-emacs +;; End: + +;;; org-bullets.el ends here diff --git a/contrib/lisp/org-checklist.el b/contrib/lisp/org-checklist.el index 1345a55..faa5998 100644 --- a/contrib/lisp/org-checklist.el +++ b/contrib/lisp/org-checklist.el @@ -1,11 +1,13 @@ ;;; org-checklist.el --- org functions for checklist handling -;; Copyright (C) 2008-2012 James TD Smith +;; Copyright (C) 2008-2013 James TD Smith ;; Author: James TD Smith (@ ahktenzero (. mohorovi cc)) ;; Version: 1.0 ;; Keywords: org, checklists ;; +;; This file is not part of GNU Emacs. +;; ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3, or (at your option) @@ -17,8 +19,7 @@ ;; 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. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: diff --git a/contrib/lisp/org-choose.el b/contrib/lisp/org-choose.el index 3513fe9..8e5935d 100644 --- a/contrib/lisp/org-choose.el +++ b/contrib/lisp/org-choose.el @@ -1,8 +1,6 @@ -;;;_ org-choose.el --- decision management for org-mode +;;; org-choose.el --- decision management for org-mode -;;;_. Headers -;;;_ , License -;; Copyright (C) 2009-2012 Tom Breton (Tehom) +;; Copyright (C) 2009-2013 Tom Breton (Tehom) ;; This file is not part of GNU Emacs. @@ -24,13 +22,13 @@ ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. -;;;_ , Commentary: +;;; 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. +;; 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) +;; 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: @@ -61,31 +59,30 @@ ;; * All the other TODO commands are available and behave essentially ;; the normal way. - -;;;_ , Requires +;;; Requires (require 'org) -;(eval-when-compile -; (require 'cl)) + ;(eval-when-compile + ; (require 'cl)) (require 'cl) -;;;_. Body -;;;_ , The variables +;;; Body +;;; The variables (defstruct (org-choose-mark-data. (:type list)) - "The format of an entry in org-choose-mark-data. + "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) + keyword + bot-lower-range + top-upper-range + range-length + static-default + all-keywords) (defvar org-choose-mark-data - () - "Alist of information for choose marks. + () + "Alist of information for choose marks. Each entry is an `org-choose-mark-data.'" ) (make-variable-buffer-local 'org-choose-mark-data) @@ -93,426 +90,394 @@ Each entry is an `org-choose-mark-data.'" ) ;;;_ . org-choose-filter-one (defun org-choose-filter-one (i) - "Return a list of + "Return a list of * a canonized version of the string * optionally one symbol" - (if + (if (not - (string-match "(.*)" i)) + (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))))) + (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 + 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 + "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 + (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 + (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))))) + "A setup filter for choose interpretations." + (when (eq (car raw) 'choose) + (cons + 'choose + (org-choose-filter-tail (cdr raw))))) -;;;_ . org-choose-conform-after-promotion +;;; 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 + (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)))))) + (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) + raise-to-ix + old-highest-ok-ix) "Conform the current item after another item was demoted." - - (unless + (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) + (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* + (let* ( (from (plist-get change-plist :from)) (to (plist-get change-plist :to)) (entry-pos - (set-marker - (make-marker) - (plist-get change-plist :position))) + (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 () + (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))) - ;;Remove the marker - (set-marker entry-pos nil))) - - - -;;;_ , Getting the default mark -;;;_ . org-choose-get-index-in-keywords +;;; 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 + (if ix (position ix all-keywords - :test #'equal))) + :test #'equal))) -;;;_ . org-choose-get-entry-index +;;; org-choose-get-entry-index (defun org-choose-get-entry-index (all-keywords) - "Return index of current entry." - - (let* + "Return index of current entry." + (let* ((state (org-entry-get (point) "TODO"))) - (org-choose-get-index-in-keywords state all-keywords))) + (org-choose-get-index-in-keywords state all-keywords))) -;;;_ . org-choose-get-fn-map-group +;;; 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 + "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. + "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 + (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)))))) - (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 +;;; 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 + (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." + "Get the text of the nth mark in a choose interpretation." - (let* + (let* ((l (org-choose-mark-data.-all-keywords data))) - (nth n l))) + (nth n l))) -;;;_ . org-choose-get-default-mark +;;; org-choose-get-default-mark (defun org-choose-get-default-mark (new-mark old-mark) - "Get the default mark IFF in a choose interpretation. + "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 + (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 @@ -524,19 +489,8 @@ NEW-MARK and OLD-MARK are the text of the new and old marks." #'org-choose-keep-sensible) (add-to-list 'org-todo-interpretation-widgets '(:tag "Choose (to record decisions)" choose) - 'append) - )) - - -;;;_. Footers -;;;_ , Provides + 'append))) (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 index 089e8ad..60b9069 100644 --- a/contrib/lisp/org-collector.el +++ b/contrib/lisp/org-collector.el @@ -1,6 +1,6 @@ ;;; org-collector --- collect properties into tables -;; Copyright (C) 2008-2012 Free Software Foundation, Inc. +;; Copyright (C) 2008-2013 Free Software Foundation, Inc. ;; Author: Eric Schulte <schulte dot eric at gmail dot com> ;; Keywords: outlines, hypermedia, calendar, wp, experimentation, @@ -10,12 +10,12 @@ ;; This file is not yet part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. -;; GNU Emacs is distributed in the hope that it will be useful, +;; 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. diff --git a/lisp/org-colview-xemacs.el b/contrib/lisp/org-colview-xemacs.el index 3da7f8d..63c0238 100644 --- a/lisp/org-colview-xemacs.el +++ b/contrib/lisp/org-colview-xemacs.el @@ -1,6 +1,6 @@ ;;; org-colview-xemacs.el --- Column View in Org-mode, XEmacs-specific version -;; Copyright (C) 2004-2012 +;; Copyright (C) 2004-2013 ;; Carsten Dominik ;; Author: Carsten Dominik <carsten at orgmode dot org> @@ -9,18 +9,19 @@ ;; ;; This file is part of Org mode, it is not part of GNU Emacs. ;; -;; 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 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 file is distributed in the hope that it will be useful, +;; 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 file; see the file COPYING. +;; along with this program. If not, see <http://www.gnu.org/licenses/>. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;; Commentary: @@ -1393,7 +1394,7 @@ PARAMS is a property list of parameters: :maxlevel When set to a number, don't capture headlines below this level. :skip-empty-rows When t, skip rows where all specifiers other than ITEM are empty." - (let ((pos (move-marker (make-marker) (point))) + (let ((pos (point-marker)) (hlines (plist-get params :hlines)) (vlines (plist-get params :vlines)) (maxlevel (plist-get params :maxlevel)) @@ -1553,7 +1554,7 @@ and tailing newline characters." ;; OK, the property is not defined. Use appointment duration? (when (and org-agenda-columns-add-appointments-to-effort-sum (setq d (get-text-property (point) 'duration))) - (setq d (org-minutes-to-hh:mm-string d)) + (setq d (org-minutes-to-clocksum-string d)) (put-text-property 0 (length d) 'face 'org-warning d) (push (cons org-effort-property d) p))) (push (cons (org-current-line) p) cache)) diff --git a/contrib/lisp/org-contacts.el b/contrib/lisp/org-contacts.el index bc52648..a3c4aed 100644 --- a/contrib/lisp/org-contacts.el +++ b/contrib/lisp/org-contacts.el @@ -1,18 +1,18 @@ ;;; org-contacts.el --- Contacts management -;; Copyright (C) 2010-2012 Julien Danjou <julien@danjou.info> +;; Copyright (C) 2010-2013 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 +;; 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. -;; GNU Emacs is distributed in the hope that it will be useful, +;; 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. @@ -39,17 +39,20 @@ (eval-when-compile (require 'cl)) -(eval-and-compile - (require 'org)) +(require 'org) (require 'gnus-util) +(require 'gnus-art) +(require 'mail-utils) +(require 'org-agenda) +(require 'org-capture) (defgroup org-contacts nil - "Options concerning contacts management." + "Options about 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." +When set to nil, all your Org files will be used." :type '(repeat file) :group 'org-contacts) @@ -58,6 +61,11 @@ If set to nil, all your Org files will be used." :type 'string :group 'org-contacts) +(defcustom org-contacts-tel-property "PHONE" + "Name of the property for contact phone number." + :type 'string + :group 'org-contacts) + (defcustom org-contacts-address-property "ADDRESS" "Name of the property for contact address." :type 'string @@ -68,8 +76,20 @@ If set to nil, all your Org files will be used." :type 'string :group 'org-contacts) +(defcustom org-contacts-note-property "NOTE" + "Name of the property for contact note." + :type 'string + :group 'org-contacts) + +(defcustom org-contacts-alias-property "ALIAS" + "Name of the property for contact name alias." + :type 'string + :group 'org-contacts) + + (defcustom org-contacts-birthday-format "Birthday: %l (%Y)" - "Format of the anniversary agenda entry. The following replacements are available: + "Format of the anniversary agenda entry. +The following replacements are available: %h - Heading name %l - Link to the heading @@ -113,7 +133,13 @@ If set to nil, all your Org files will be used." :type 'string :group 'org-contacts) -(defcustom org-contacts-matcher (concat org-contacts-email-property "<>\"\"") +(defcustom org-contacts-matcher + (mapconcat 'identity (list org-contacts-email-property + org-contacts-alias-property + org-contacts-tel-property + org-contacts-address-property + org-contacts-birthday-property) + "<>\"\"|") "Matching rule for finding heading that are contacts. This can be a tag name, or a property check." :type 'string @@ -130,6 +156,24 @@ This overrides `org-email-link-description-format' if set." :group 'org-contacts :type 'file) +(defcustom org-contacts-enable-completion t + "Enable or not the completion in `message-mode' with `org-contacts'." + :group 'org-contacts + :type 'boolean) + +;; Decalre external functions and variables +(declare-function org-reverse-string "org") +(declare-function diary-ordinal-suffix "ext:diary-lib") +(declare-function wl-summary-message-number "ext:wl-summary") +(declare-function wl-address-header-extract-address "ext:wl-address") +(declare-function wl-address-header-extract-realname "ext:wl-address") +(declare-function erc-buffer-list "ext:erc") +(declare-function erc-get-channel-user-list "ext:erc") +(declare-function google-maps-static-show "ext:google-maps-static") +(declare-function elmo-message-field "ext:elmo-pipe") +(declare-function std11-narrow-to-header "ext:std11") +(declare-function std11-fetch-field "ext:std11") + (defvar org-contacts-keymap (let ((map (make-sparse-keymap))) (define-key map "M" 'org-contacts-view-send-email) @@ -137,38 +181,66 @@ This overrides `org-email-link-description-format' if set." map) "The keymap used in `org-contacts' result list.") +(defvar org-contacts-db nil + "Org Contacts database.") + +(defvar org-contacts-last-update nil + "Last time the Org Contacts database has been updated.") + (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-db-need-update-p () + "Determine whether `org-contacts-db' needs to be refreshed." + (or (null org-contacts-last-update) + (org-find-if (lambda (file) + (or (time-less-p org-contacts-last-update + (elt (file-attributes file) 5)))) + (org-contacts-files)))) + +(defun org-contacts-db () + "Return the latest Org Contacts Database." + (let* (todo-only + (contacts-matcher + (cdr (org-make-tags-matcher org-contacts-matcher))) + markers result) + (when (org-contacts-db-need-update-p) + (message "Update Org Contacts Database") + (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))) + contacts-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))))) + (setf org-contacts-db result + org-contacts-last-update (current-time))) + org-contacts-db)) + (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))))))) + (if (and (null name-match) + (null tags-match)) + (org-contacts-db) + (loop for contact in (org-contacts-db) + if (or + (and name-match + (org-string-match-p name-match + (first contact))) + (and tags-match + (org-find-if (lambda (tag) + (org-string-match-p tags-match tag)) + (org-split-string + (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":")))) + collect contact))) (when (not (fboundp 'completion-table-case-fold)) ;; That function is new in Emacs 24... @@ -177,67 +249,256 @@ If both match values are nil, return all contacts." (let ((completion-ignore-case (not dont-fold))) (complete-with-action action table string pred))))) -(defun org-contacts-complete-name (&optional start) +(defun org-contacts-try-completion-prefix (to-match collection &optional predicate) + "Custom implementation of `try-completion'. +This version works only with list and alist and it looks at all +prefixes rather than just the beginning of the string." + (loop with regexp = (concat "\\b" (regexp-quote to-match)) + with ret = nil + with ret-start = nil + with ret-end = nil + + for el in collection + for string = (if (listp el) (car el) el) + + for start = (when (or (null predicate) (funcall predicate string)) + (string-match regexp string)) + + if start + do (let ((end (match-end 0)) + (len (length string))) + (if (= end len) + (return t) + (destructuring-bind (string start end) + (if (null ret) + (values string start end) + (org-contacts-common-substring + ret ret-start ret-end + string start end)) + (setf ret string + ret-start start + ret-end end)))) + + finally (return + (replace-regexp-in-string "\\`[ \t\n]*" "" ret)))) + +(defun org-contacts-compare-strings (s1 start1 end1 s2 start2 end2 &optional ignore-case) + "Compare the contents of two strings, using `compare-strings'. + +This function works like `compare-strings' excepted that it +returns a cons. +- The CAR is the number of characters that match at the beginning. +- The CDR is T is the two strings are the same and NIL otherwise." + (let ((ret (compare-strings s1 start1 end1 s2 start2 end2 ignore-case))) + (if (eq ret t) + (cons (or end1 (length s1)) t) + (cons (1- (abs ret)) nil)))) + +(defun org-contacts-common-substring (s1 start1 end1 s2 start2 end2) + "Extract the common substring between S1 and S2. + +This function extracts the common substring between S1 and S2 and +adjust the part that remains common. + +START1 and END1 delimit the part in S1 that we know is common +between the two strings. This applies to START2 and END2 for S2. + +This function returns a list whose contains: +- The common substring found. +- The new value of the start of the known inner substring. +- The new value of the end of the known inner substring." + ;; Given two strings: + ;; s1: "foo bar baz" + ;; s2: "fooo bar baz" + ;; and the inner substring is "bar" + ;; then: start1 = 4, end1 = 6, start2 = 5, end2 = 7 + ;; + ;; To find the common substring we will compare two substrings: + ;; " oof" and " ooof" to find the beginning of the common substring. + ;; " baz" and " baz" to find the end of the common substring. + (let* ((len1 (length s1)) + (start1 (or start1 0)) + (end1 (or end1 len1)) + + (len2 (length s2)) + (start2 (or start2 0)) + (end2 (or end2 len2)) + + (new-start (car (org-contacts-compare-strings + (substring (org-reverse-string s1) (- len1 start1)) nil nil + (substring (org-reverse-string s2) (- len2 start2)) nil nil))) + + (new-end (+ end1 (car (org-contacts-compare-strings + (substring s1 end1) nil nil + (substring s2 end2) nil nil))))) + (list (substring s1 (- start1 new-start) new-end) + new-start + (+ new-start (- end1 start1))))) + +(defun org-contacts-all-completions-prefix (to-match collection &optional predicate) + "Custom version of `all-completions'. +This version works only with list and alist and it looks at all +prefixes rather than just the beginning of the string." + (loop with regexp = (concat "\\b" (regexp-quote to-match)) + for el in collection + for string = (if (listp el) (car el) el) + for match? = (when (and (or (null predicate) (funcall predicate string))) + (string-match regexp string)) + if match? + collect (progn + (let ((end (match-end 0))) + (org-no-properties string) + (when (< end (length string)) + ;; Here we add a text property that will be used + ;; later to highlight the character right after + ;; the common part between each addresses. + ;; See `org-contacts-display-sort-function'. + (put-text-property end (1+ end) 'org-contacts-prefix 't string))) + string))) + +(defun org-contacts-make-collection-prefix (collection) + "Make a collection function from COLLECTION which will match on prefixes." + (lexical-let ((collection collection)) + (lambda (string predicate flag) + (cond ((eq flag nil) + (org-contacts-try-completion-prefix string collection predicate)) + ((eq flag t) + ;; `org-contacts-all-completions-prefix' has already been + ;; used to compute `all-completions'. + collection) + ((eq flag 'lambda) + (org-contacts-test-completion-prefix string collection predicate)) + ((and (listp flag) (eq (car flag) 'boundaries)) + (destructuring-bind (to-ignore &rest suffix) + flag + (org-contacts-boundaries-prefix string collection predicate suffix))) + ((eq flag 'metadata) + (org-contacts-metadata-prefix string collection predicate)) + (t nil ; operation unsupported + ))))) + +(defun org-contacts-display-sort-function (completions) + "Sort function for contacts display." + (mapcar (lambda (string) + (loop with len = (1- (length string)) + for i upfrom 0 to len + if (memq 'org-contacts-prefix + (text-properties-at i string)) + do (set-text-properties + i (1+ i) + (list 'font-lock-face + (if (char-equal (aref string i) + (string-to-char " ")) + ;; Spaces can't be bold. + 'underline + 'bold)) string) + else + do (set-text-properties i (1+ i) nil string) + finally (return string))) + completions)) + +(defun org-contacts-test-completion-prefix (string collection predicate) + ;; Prevents `org-find-if' from redefining `predicate' and going into + ;; an infinite loop. + (lexical-let ((predicate predicate)) + (org-find-if (lambda (el) + (and (or (null predicate) (funcall predicate el)) + (string= string el))) + collection))) + +(defun org-contacts-boundaries-prefix (string collection predicate suffix) + (list* 'boundaries (completion-boundaries string collection predicate suffix))) + +(defun org-contacts-metadata-prefix (string collection predicate) + '(metadata . + ((display-sort-function . org-contacts-display-sort-function)))) + +(defun org-contacts-complete-group (start end string) + "Complete text at START from a group. + +A group FOO is composed of contacts with the tag FOO." + (let* ((completion-ignore-case org-contacts-completion-ignore-case) + (group-completion-p (org-string-match-p + (concat "^" org-contacts-group-prefix) string))) + (when group-completion-p + (let ((completion-list + (all-completions + string + (mapcar (lambda (group) + (propertize (concat org-contacts-group-prefix group) + 'org-contacts-group group)) + (org-uniquify + (loop for contact in (org-contacts-filter) + nconc (org-split-string + (or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))))) + (list start end + (if (= (length completion-list) 1) + ;; We've foudn the correct group, returns the address + (lexical-let ((tag (get-text-property 0 'org-contacts-group + (car completion-list)))) + (lambda (string pred &optional to-ignore) + (mapconcat 'identity + (loop for contact in (org-contacts-filter + nil + tag) + ;; 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)) + ", "))) + ;; We haven't found the correct group + (completion-table-case-fold completion-list + (not org-contacts-completion-ignore-case)))))))) + +(defun org-contacts-complete-name (start end string) "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)) + (let* ((completion-ignore-case org-contacts-completion-ignore-case) (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 () + (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 (org-contacts-all-completions-prefix + string + (org-uniquify completion-list)))) + (when completion-list + (list start end + (org-contacts-make-collection-prefix completion-list))))) + +(defun org-contacts-message-complete-function (&optional start) "Function used in `completion-at-point-functions' in `message-mode'." + ;; Avoid to complete in `post-command-hook'. + (when completion-in-region-mode + (remove-hook 'post-command-hook #'completion-in-region--postch)) (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)))) + (when (mail-abbrev-in-expansion-header-p) + (lexical-let* + ((end (point)) + (start (or start + (save-excursion + (re-search-backward "\\(\\`\\|[\n:,]\\)[ \t]*") + (goto-char (match-end 0)) + (point)))) + (string (buffer-substring start end))) + (or (org-contacts-complete-group start end string) + (org-contacts-complete-name start end string)))))) (defun org-contacts-gnus-get-name-email () "Get name and email address from Gnus message." @@ -272,6 +533,7 @@ If both match values are nil, return all contacts." ;; show the next heading (org-flag-heading nil))))))) +(org-no-warnings (defvar date)) ;; unprefixed, from calendar.el (defun org-contacts-anniversaries (&optional field format) "Compute FIELD anniversary for each contact, returning FORMAT. Default FIELD value is \"BIRTHDAY\". @@ -342,6 +604,7 @@ This function should be called from `gnus-article-prepare-hook'." (org-set-property org-contacts-last-read-mail-property link))))))) (defun org-contacts-icon-as-string () + "Return the contact icon as a string." (let ((image (org-contacts-get-icon))) (concat (propertize "-" 'display @@ -359,9 +622,9 @@ This function should be called from `gnus-article-prepare-hook'." (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-prefix-format (propertize + "%(org-contacts-icon-as-string)% s%(org-contacts-irc-number-of-unread-messages) " + 'keymap org-contacts-keymap)) (org-agenda-overriding-header (or org-agenda-overriding-header (concat "List of contacts matching `" name "':")))) @@ -378,12 +641,17 @@ This function should be called from `gnus-article-prepare-hook'." (org-completing-read prompt (org-contacts-filter) predicate t initial-input hist def inherit-input-method)) +(defun org-contacts-format-name (name) + "Trim any local formatting to get a bare NAME." + ;; Remove radio targets characters + (replace-regexp-in-string org-radio-target-regexp "\\1" name)) + (defun org-contacts-format-email (name email) - "Format a mail address." + "Format an EMAIL address corresponding to NAME." (unless email (error "`email' cannot be nul")) (if name - (concat name " <" email ">") + (concat (org-contacts-format-name name) " <" email ">") email)) (defun org-contacts-check-mail-address (mail) @@ -406,7 +674,7 @@ This function should be called from `gnus-article-prepare-hook'." "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-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) @@ -414,7 +682,8 @@ This adds `org-contacts-gnus-check-mail-address' and (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) +(when (and org-contacts-enable-completion + (boundp 'completion-at-point-functions)) (add-hook 'message-mode-hook (lambda () (add-to-list 'completion-at-point-functions @@ -426,18 +695,19 @@ 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 + ((eq major-mode 'wl-summary-mode) (when (and (boundp 'wl-summary-buffer-elmo-folder) + 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)))))) + (prog1 + (std11-fetch-field "From") + (widen)))))) (defun org-contacts-wl-get-name-email () - "Get name and email address from wanderlust 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 @@ -446,13 +716,14 @@ See `org-contacts-wl-get-from-header-content' for limitations." (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." +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. + "Try to return the contact email for a template from Wanderlust. If not found return RETURN-VALUE or something that would ask the user." (or (cadr (org-contacts-wl-get-name-email)) return-value @@ -460,7 +731,8 @@ If not found return RETURN-VALUE or something that would ask the user." (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." +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 @@ -536,24 +808,31 @@ If ASK is set, ask for the email address even if there's only one address." (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)))))) + (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." + "Escape ; , and \n in STR for the VCard format." + ;; Thanks to this library for the regexp: + ;; http://www.emacswiki.org/cgi-bin/wiki/bbdb-vcard-export.el (when str - (replace-regexp-in-string "\n" "\\\\n" (replace-regexp-in-string "\\(;\\|,\\|\\\\\\)" "\\\\\\1" 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." + "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) @@ -561,16 +840,30 @@ Org-contacts does not specify how to encode the name. So we try to do our best." (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)))) + (email (cdr (assoc-string org-contacts-email-property properties))) + (tel (cdr (assoc-string org-contacts-tel-property properties))) + (note (cdr (assoc-string org-contacts-note-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 email (progn + (setq emails-list (split-string email "[,;: ]+")) + (setq result "") + (while emails-list + (setq result (concat result "EMAIL:" (car emails-list) "\n")) + (setq emails-list (cdr emails-list))) + result)) (when addr (format "ADR:;;%s\n" (replace-regexp-in-string "\\, ?" ";" addr))) + (when tel (progn + (setq phones-list (split-string tel "[,;: ]+")) + (setq result "") + (while phones-list + (setq result (concat result "TEL:" (car phones-list) "\n")) + (setq phones-list (cdr phones-list))) + result)) (when bday (let ((cal-bday (calendar-gregorian-from-absolute (org-time-string-to-absolute bday)))) (format "BDAY:%04d-%02d-%02d\n" @@ -578,44 +871,47 @@ Org-contacts does not specify how to encode the name. So we try to do our best." (calendar-extract-month cal-bday) (calendar-extract-day cal-bday)))) (when nick (format "NICKNAME:%s\n" nick)) + (when note (format "NOTE:%s\n" note)) "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." + "Export all contacts matching NAME as VCard 3.0. +If 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)))) - + (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))) - + do (insert (org-contacts-vcard-format contact))) (if to-buffer (current-buffer) - (progn (save-buffer) (kill-buffer))))) + (progn (save-buffer) (kill-buffer))))) (defun org-contacts-show-map (&optional name) - "Show contacts on a map. Requires google-maps-el." + "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))))))) + 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) (provide 'org-contacts) + +;;; org-contacts.el ends here diff --git a/contrib/lisp/org-contribdir.el b/contrib/lisp/org-contribdir.el index 37b06a4..8132750 100644 --- a/contrib/lisp/org-contribdir.el +++ b/contrib/lisp/org-contribdir.el @@ -1,5 +1,5 @@ ;;; org-contribdir.el --- Mark the location of the contrib directory -;; Copyright (C) 2009-2012 Free Software Foundation, Inc. +;; Copyright (C) 2009-2013 Free Software Foundation, Inc. ;; ;; Author: Carsten Dominik <carsten at orgmode dot org> ;; Keywords: outlines, hypermedia, calendar, wp @@ -8,12 +8,12 @@ ;; ;; This file is not yet part of GNU Emacs. ;; -;; GNU Emacs is free software; you can redistribute it and/or modify +;; 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. -;; GNU Emacs is distributed in the hope that it will be useful, +;; 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. diff --git a/contrib/lisp/org-depend.el b/contrib/lisp/org-depend.el index d741dbe..dc99a1d 100644 --- a/contrib/lisp/org-depend.el +++ b/contrib/lisp/org-depend.el @@ -1,5 +1,5 @@ ;;; org-depend.el --- TODO dependencies for Org-mode -;; Copyright (C) 2008-2012 Free Software Foundation, Inc. +;; Copyright (C) 2008-2013 Free Software Foundation, Inc. ;; ;; Author: Carsten Dominik <carsten at orgmode dot org> ;; Keywords: outlines, hypermedia, calendar, wp @@ -13,15 +13,13 @@ ;; 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, +;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;; Commentary: @@ -205,13 +203,15 @@ This does two different kinds of triggers: 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." + ;; Refresh the effort text properties + (org-refresh-properties org-effort-property 'org-effort) ;; 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) + trigger triggers tr p1 kwd id) (catch 'return (unless (eq type 'todo-state-change) ;; We are only handling todo-state-change.... @@ -268,7 +268,7 @@ This does two different kinds of triggers: (tags (match-string 5)) (priority (org-get-priority (or (match-string 3) ""))) (effort (when (or effort-up effort-down) - (let ((effort (org-get-effort))) + (let ((effort (get-text-property (point) 'org-effort))) (when effort (org-duration-string-to-minutes effort)))))) (push (list (point) todo-kwd priority tags effort) @@ -311,15 +311,15 @@ This does two different kinds of triggers: (cond (priority-up (or p1-gt (and (equal p1 p2) - (or (and effort-up e1-gt) - (and effort-down e1-lt))))) + (or (and effort-up e1-lt) + (and effort-down e2-gt))))) (priority-down (or p1-lt (and (equal p1 p2) - (or (and effort-up e1-gt) - (and effort-down e1-lt))))) + (or (and effort-up e1-lt) + (and effort-down e2-gt))))) (effort-up - (or e1-gt (and (equal e1 e2) p1-gt))) + (or e2-gt (and (equal e1 e2) p1-gt))) (effort-down (or e1-lt (and (equal e1 e2) p1-gt)))))))) (when items diff --git a/contrib/lisp/org-drill.el b/contrib/lisp/org-drill.el index 2ffc201..5bf6dd4 100644 --- a/contrib/lisp/org-drill.el +++ b/contrib/lisp/org-drill.el @@ -1,28 +1,42 @@ -;;; -*- coding: utf-8-unix -*- +;; -*- 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/ +;; Author: Paul Sexton <eeeickythump@gmail.com> +;; Version: 2.3.7 +;; Repository at http://bitbucket.org/eeeickythump/org-drill/ +;; +;; This file is not part of GNU Emacs. +;; +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 3, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary and synopsis: ;;; -;;; -;;; 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. - +;; 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. +;; +;;; Code: (eval-when-compile (require 'cl)) (eval-when-compile (require 'hi-lock)) @@ -30,41 +44,30 @@ (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" +(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 +(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 +(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 +(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 @@ -78,9 +81,7 @@ really sensible." :group 'org-drill :type '(choice (const 2) (const 1))) - -(defcustom org-drill-forgetting-index - 10 +(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 @@ -88,17 +89,13 @@ climbs above this number." :group 'org-drill :type 'integer) - -(defcustom org-drill-leech-failure-threshold - 15 +(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 +(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. @@ -109,71 +106,58 @@ Possible values: :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 +(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 +(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" +(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" +(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" +(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" +(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 @@ -187,60 +171,70 @@ during a drill session." face default window t)) +(defvar org-drill-hint-separator "||" + "String which, if it occurs within a cloze expression, signifies that the +rest of the expression after the string is a `hint', to be displayed instead of +the hidden cloze during a test.") (defvar org-drill-cloze-regexp - ;; ver 1 "[^][]\\(\\[[^][][^]]*\\]\\)" - ;; ver 2 "\\(\\[.*?\\]\\|^[^[[:cntrl:]]*?\\]\\|\\[.*?$\\)" - ;; ver 3! "\\(\\[.*?\\]\\|\\[.*?[[:cntrl:]]+.*?\\]\\)" - "\\(\\[[[:cntrl:][:graph:][:space:]]*?\\)\\(\\||.+?\\)\\(\\]\\)") - + (concat "\\(\\[[[:cntrl:][:graph:][:space:]]+?\\)\\(\\|" + (regexp-quote org-drill-hint-separator) + ".+?\\)\\(\\]\\)")) (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) - ))) - + (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 + '((nil org-drill-present-simple-card) + ("simple" org-drill-present-simple-card) + ("twosided" org-drill-present-two-sided-card nil t) + ("multisided" org-drill-present-multi-sided-card nil t) + ("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)." + ("decline_noun" + org-drill-present-noun-declension + org-drill-show-answer-noun-declension) + ("spanish_verb" org-drill-present-spanish-verb) + ("translate_number" org-drill-present-translate-number)) + "Alist associating card types with presentation functions. Each +entry in the alist takes the form: + +;;; (CARDTYPE QUESTION-FN [ANSWER-FN DRILL-EMPTY-P]) + +Where CARDTYPE is a string or nil (for default), and QUESTION-FN +is a function which takes no arguments and returns a boolean +value. + +When supplied, ANSWER-FN is a function that takes one argument -- +that argument is a function of no arguments, which when called, +prompts the user to rate their recall and performs rescheduling +of the drill item. 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. + +When supplied, DRILL-EMPTY-P is a boolean value, default nil. +When non-nil, cards of this type will be presented during tests +even if their bodies are empty." :group 'org-drill - :type '(alist :key-type (choice string (const nil)) :value-type function)) - + :type '(alist :key-type (choice string (const nil)) + :value-type function)) -(defcustom org-drill-scope - 'file +(defcustom org-drill-scope 'file "The scope in which to search for drill items when conducting a drill session. This can be any of: @@ -267,17 +261,13 @@ directory All files with the extension '.org' in the same (const 'agenda-with-archives) (const 'directory) list)) - -(defcustom org-drill-save-buffers-after-drill-sessions-p - t +(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 +(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 @@ -292,9 +282,7 @@ Available choices are: :group 'org-drill :type '(choice (const 'sm2) (const 'sm5) (const 'simple8))) - -(defcustom org-drill-optimal-factor-matrix - nil +(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. @@ -306,18 +294,14 @@ pace of learning." :group 'org-drill :type 'sexp) - -(defcustom org-drill-sm5-initial-interval - 4.0 +(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 +(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 @@ -325,9 +309,7 @@ small, but scales up with the interval." :group 'org-drill :type 'boolean) - -(defcustom org-drill-adjust-intervals-for-early-and-late-repetitions-p - nil +(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 @@ -342,9 +324,7 @@ is used." :group 'org-drill :type 'boolean) - -(defcustom org-drill-cloze-text-weight - 4 +(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 @@ -363,15 +343,12 @@ all weighted card types are treated as their unweighted equivalents." :group 'org-drill :type '(choice integer (const nil))) - -(defcustom org-drill-cram-hours - 12 +(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 @@ -384,17 +361,13 @@ they were reviewed at least this many hours ago." ;;; LAST-INTERVAL * (ORG-DRILL-OVERDUE-INTERVAL-FACTOR - 1) days, ;;; regardless of young/old status. - -(defcustom org-drill-days-before-old - 10 +(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 +(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 @@ -406,9 +379,7 @@ should never be less than 1.0." :group 'org-drill :type 'float) - -(defcustom org-drill-learn-fraction - 0.5 +(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 @@ -418,6 +389,15 @@ exponential effect on inter-repetition spacing." :group 'org-drill :type 'float) +(defvar drill-answer nil + "Global variable that can be bound to a correct answer when an +item is being presented. If this variable is non-nil, the default +presentation function will show its value instead of the default +behaviour of revealing the contents of the drilled item. + +This variable is useful for card types that compute their answers +-- for example, a card type that asks the student to translate a +random number to another language. ") (defvar *org-drill-session-qualities* nil) (defvar *org-drill-start-time* 0) @@ -448,10 +428,8 @@ for review unless they were already reviewed in the recent past?") "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)))) @@ -480,14 +458,11 @@ for review unless they were already reviewed in the recent past?") (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) @@ -497,13 +472,11 @@ for review unless they were already reviewed in the recent past?") (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 @@ -519,27 +492,23 @@ value." (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))) @@ -554,7 +523,6 @@ CMD is bound, or nil if it is not bound to a key." (t org-drill-scope)) skip))) - (defmacro with-hidden-cloze-text (&rest body) `(progn (org-drill-hide-clozed-text) @@ -563,7 +531,6 @@ CMD is bound, or nil if it is not bound to a key." ,@body) (org-drill-unhide-clozed-text)))) - (defmacro with-hidden-cloze-hints (&rest body) `(progn (org-drill-hide-cloze-hints) @@ -572,7 +539,6 @@ CMD is bound, or nil if it is not bound to a key." ,@body) (org-drill-unhide-text)))) - (defmacro with-hidden-comments (&rest body) `(progn (if org-drill-hide-item-headings-p @@ -583,7 +549,6 @@ CMD is bound, or nil if it is not bound to a key." ,@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. @@ -597,7 +562,6 @@ this should never happen." (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." @@ -609,7 +573,6 @@ in hours rather than days." (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 @@ -619,12 +582,10 @@ situation use `org-part-of-drill-entry-p'." (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?" @@ -632,7 +593,6 @@ or a subheading within a drill item?" ;; 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." @@ -644,14 +604,11 @@ drill entry." (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* @@ -669,7 +626,6 @@ drill entry." ;; (- (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. @@ -699,7 +655,6 @@ drill entry." (- (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 @@ -715,34 +670,28 @@ from the entry at point." (> (/ (+ 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 @@ -773,7 +722,6 @@ from the entry at point." (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." @@ -796,10 +744,9 @@ from the entry at point." (- variation) mean)) - (defun org-drill-early-interval-factor (optimal-factor - optimal-interval - days-ahead) + optimal-interval + days-ahead) "Arguments: - OPTIMAL-FACTOR: interval-factor if the item had been tested exactly when it was supposed to be. @@ -816,7 +763,6 @@ in the matrix." (- 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: @@ -854,7 +800,6 @@ in the matrix." (t ; virgin item (list 0 0 0 0 nil nil))))) - (defun org-drill-store-item-data (last-interval repeats failures total-repeats meanq ease) @@ -870,11 +815,8 @@ in the matrix." (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: @@ -923,8 +865,6 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher ;;; SM5 Algorithm ============================================================= - - (defun initial-optimal-factor-sm5 (n ef) (if (= 1 n) org-drill-sm5-initial-interval @@ -937,7 +877,6 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher (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)))) @@ -945,7 +884,6 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher of (* of last-interval)))) - (defun determine-next-interval-sm5 (last-interval n ef quality failures meanq total-repeats of-matrix &optional delta-days) @@ -956,12 +894,10 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher (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) @@ -974,13 +910,10 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher (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) @@ -1005,10 +938,8 @@ Returns a list: (INTERVAL REPEATS EF FAILURES MEAN TOTAL-REPEATS OFMATRIX), wher (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 @@ -1018,7 +949,6 @@ 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. @@ -1029,7 +959,6 @@ 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." @@ -1039,7 +968,6 @@ to a mean item quality of QUALITY." (* -1.2403 quality) 1.4515)) - (defun determine-next-interval-simple8 (last-interval repeats quality failures meanq totaln &optional delta-days) @@ -1106,11 +1034,7 @@ See the documentation for `org-drill-get-item-data' for a description of these." (org-drill-simple8-quality->ease meanq) failures meanq - totaln - ))) - - - + totaln))) ;;; Essentially copied from `org-learn.el', but modified to ;;; optionally call the SM2 or simple8 functions. @@ -1261,35 +1185,35 @@ How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)" ((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))) + (unless *org-drill-cram-mode* + (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." @@ -1310,8 +1234,6 @@ How well did you do? (0-5, ?=help, e=edit, t=tags, q=quit)" ;; "" '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 @@ -1334,13 +1256,11 @@ the current topic." "" '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) @@ -1361,9 +1281,13 @@ the current topic." (format "%s %s %s %s %s %s" (propertize (char-to-string - (case status - (:new ?N) (:young ?Y) (:old ?o) (:overdue ?!) - (:failed ?F) (t ??))) + (cond + ((eql status :failed) ?F) + (*org-drill-cram-mode* ?C) + (t + (case status + (:new ?N) (:young ?Y) (:old ?o) (:overdue ?!) + (t ??))))) 'face `(:foreground ,(case status (:new org-drill-new-count-color) @@ -1417,13 +1341,11 @@ Consider reformulating the item to make it easier to remember.\n" (?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." @@ -1435,22 +1357,19 @@ visual overlay, or with the string TEXT if it is supplied." (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")) + (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 @@ -1458,7 +1377,6 @@ visual overlay, or with the string TEXT if it is supplied." (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) @@ -1469,25 +1387,26 @@ visual overlay, or with the string TEXT if it is supplied." 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)))) + (let ((ovl (make-overlay (match-beginning 0) (match-end 0))) + (hint-sep-pos (string-match-p (regexp-quote org-drill-hint-separator) + (match-string 0)))) (overlay-put ovl 'category 'org-drill-cloze-overlay-defaults) - (when (find ?| (match-string 0)) + (when (and hint-sep-pos + (> hint-sep-pos 1)) (let ((hint (substring-no-properties (match-string 0) - (1+ (position ?| (match-string 0))) + (+ hint-sep-pos (length org-drill-hint-separator)) (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...]") + (format (if (string-match-p (regexp-quote "...") hint) "[%s]" "[%s...]") hint)))))) - (defun org-drill-hide-cloze-hints () (save-excursion (while (re-search-forward org-drill-cloze-regexp nil t) @@ -1497,7 +1416,6 @@ visual overlay, or with the string TEXT if it is supplied." (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." @@ -1508,7 +1426,6 @@ concealed by an overlay that displays the string TEXT." ,@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." @@ -1519,7 +1436,6 @@ concealed by an overlay that displays the overlays in REPLACEMENTS." ,@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 @@ -1542,14 +1458,12 @@ Note: does not actually alter the item." '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 @@ -1570,7 +1484,6 @@ Note: does not actually alter the item." '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) @@ -1579,21 +1492,18 @@ Note: does not actually alter the item." ,@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 @@ -1601,13 +1511,23 @@ Note: does not actually alter the item." (substring-no-properties text)))) -(defun org-drill-entry-empty-p () - (zerop (length (org-drill-get-entry-text)))) +;; (defun org-entry-empty-p () +;; (zerop (length (org-drill-get-entry-text)))) +;; This version is about 5x faster than the old version, above. +(defun org-entry-empty-p () + (save-excursion + (org-back-to-heading t) + (let ((lim (save-excursion + (outline-next-heading) (point)))) + (org-end-of-meta-data-and-drawers) + (or (>= (point) lim) + (null (re-search-forward "[[:graph:]]" lim t)))))) +(defun org-drill-entry-empty-p () (org-entry-empty-p)) ;;; 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 @@ -1626,15 +1546,22 @@ Note: does not actually alter the item." (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))) - + (cond + (drill-answer + (with-replaced-entry-text + (format "\nAnswer:\n\n %s\n" drill-answer) + (prog1 + (funcall reschedule-fn) + (setq drill-answer nil)))) + (t + (org-drill-hide-subheadings-if 'org-drill-entry-p) + (org-drill-unhide-clozed-text) + (ignore-errors + (org-display-inline-images t)) + (org-cycle-hide-drawers 'all) + (with-hidden-cloze-hints + (funcall reschedule-fn))))) (defun org-drill-present-two-sided-card () (with-hidden-comments @@ -1652,8 +1579,6 @@ Note: does not actually alter the item." (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 @@ -1669,7 +1594,6 @@ Note: does not actually alter the item." (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 @@ -1749,7 +1673,6 @@ items if FORCE-SHOW-FIRST or FORCE-SHOW-LAST is non-nil)." (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 @@ -1797,29 +1720,24 @@ the second to last, etc." (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, @@ -1849,7 +1767,6 @@ the value of `org-drill-cloze-text-weight'." ;; 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 @@ -1874,7 +1791,6 @@ the value of `org-drill-cloze-text-weight'." ;; 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 @@ -1900,20 +1816,17 @@ the value of `org-drill-cloze-text-weight'." ;; 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 @@ -1947,12 +1860,13 @@ pieces rather than one." ;; (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." + "Present the string QUESTION as the only visible content of the card. +If ANSWER is supplied, set the global variable `drill-answer' to its value." + (if answer (setq drill-answer answer)) (with-hidden-comments (with-replaced-entry-text - question + (concat "\n" question) (org-drill-hide-all-subheadings-except nil) (org-cycle-hide-drawers 'all) (ignore-errors @@ -1960,11 +1874,12 @@ pieces rather than one." (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." +visible content of the card. +If ANSWER is supplied, set the global variable `drill-answer' to its value." + (if answer (setq drill-answer answer)) (with-hidden-comments (with-replaced-entry-text-multi replacements @@ -1975,7 +1890,6 @@ visible content of the card." (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 @@ -1995,20 +1909,24 @@ See `org-drill' for more details." ;; (org-back-to-heading)) (let ((card-type (org-entry-get (point) "DRILL_CARD_TYPE")) (answer-fn 'org-drill-present-default-answer) + (present-empty-cards nil) (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)) + (setq drill-answer 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)))) + (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) + present-empty-cards (third presentation-fn) presentation-fn (first presentation-fn))) (cond ((null presentation-fn) @@ -2031,9 +1949,9 @@ See `org-drill' for more details." (funcall answer-fn (lambda () (org-drill-reschedule))))))))))))) - (defun org-drill-entries-pending-p () (or *org-drill-again-entries* + *org-drill-current-item* (and (not (org-drill-maximum-item-count-reached-p)) (not (org-drill-maximum-duration-reached-p)) (or *org-drill-new-entries* @@ -2043,33 +1961,32 @@ See `org-drill' for more details." *org-drill-overdue-entries* *org-drill-again-entries*)))) - (defun org-drill-pending-entry-count () - (+ (length *org-drill-new-entries*) + (+ (if (markerp *org-drill-current-item*) 1 0) + (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 + (not *org-drill-cram-mode*) *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 + (not *org-drill-cram-mode*) (>= (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)) @@ -2117,7 +2034,6 @@ maximum number of items." (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. @@ -2157,6 +2073,7 @@ RESUMING-P is true if we are resuming a suspended drill session." (setq end-pos (point-marker)) (return-from org-drill-entries nil)) ((eql result 'skip) + (setq *org-drill-current-item* nil) nil) ; skip this item (t (cond @@ -2166,9 +2083,8 @@ RESUMING-P is true if we are resuming a suspended drill session." (shuffle-list *org-drill-again-entries*))) (push-end m *org-drill-again-entries*)) (t - (push m *org-drill-done-entries*)))))))))))) - - + (push m *org-drill-done-entries*))) + (setq *org-drill-current-item* nil)))))))))) (defun org-drill-final-report () (let ((pass-percent @@ -2176,7 +2092,8 @@ RESUMING-P is true if we are resuming a suspended drill session." (> qual org-drill-failure-quality)) *org-drill-session-qualities*)) (max 1 (length *org-drill-session-qualities*)))) - (prompt nil)) + (prompt nil) + (max-mini-window-height 0.6)) (setq prompt (format "%d items reviewed. Session duration %s. @@ -2255,10 +2172,7 @@ order to make items appear more frequently over time." *org-drill-overdue-entry-count* (round (* 100 *org-drill-overdue-entry-count*) (+ *org-drill-dormant-entry-count* - *org-drill-due-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 @@ -2305,8 +2219,14 @@ one of the following values: (cond ((not (org-drill-entry-p)) nil) - ((org-drill-entry-empty-p) - nil) ; skip -- item body is empty + ((and (org-entry-empty-p) + (let* ((card-type (org-entry-get (point) "DRILL_CARD_TYPE" nil)) + (dat (cdr (assoc card-type org-drill-card-type-alist)))) + (or (null card-type) + (not (third dat))))) + ;; body is empty, and this is not a card type where empty bodies are + ;; meaningful, so skip it. + nil) ((null due) ; unscheduled - usually a skipped leech :unscheduled) ;; ((eql -1 due) @@ -2446,47 +2366,16 @@ than starting a new one." (:overdue (push (cons (point-marker) due) overdue-data)) (:old - (push (point-marker) *org-drill-old-mature-entries*))))))) + (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*) + ((and (null *org-drill-current-item*) + (null *org-drill-new-entries*) (null *org-drill-failed-entries*) (null *org-drill-overdue-entries*) (null *org-drill-young-mature-entries*) @@ -2497,6 +2386,7 @@ than starting a new one." (message "Drill session finished!")))) (progn (unless end-pos + (setq *org-drill-cram-mode* nil) (org-drill-free-markers *org-drill-done-entries*))))) (cond (end-pos @@ -2515,8 +2405,7 @@ than starting a new one." (org-drill-save-optimal-factor-matrix)) (if org-drill-save-buffers-after-drill-sessions-p (save-some-buffers)) - (message "Drill session finished!") - )))) + (message "Drill session finished!"))))) (defun org-drill-save-optimal-factor-matrix () @@ -2531,8 +2420,8 @@ 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))) + (setq *org-drill-cram-mode* t) + (org-drill scope)) (defun org-drill-tree () @@ -2555,6 +2444,7 @@ 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) + (setq *org-drill-cram-mode* nil) (cond ((plusp (org-drill-pending-entry-count)) (org-drill-free-markers *org-drill-done-entries*) @@ -2675,9 +2565,7 @@ the tag 'imported'." (outline-next-heading) (newline) (forward-line -1) - (paste-tree-here (1+ (or (org-current-level) 0))) - ))))) - + (paste-tree-here (1+ (or (org-current-level) 0)))))))) (defun org-drill-merge-buffers (src &optional dest ignore-new-items-p) @@ -2770,15 +2658,12 @@ copy them across." (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 @@ -2883,19 +2768,120 @@ returns its return value." (mood (format "%s mood" mood)))) infinitive translation) + (org-cycle-hide-drawers 'all) + (funcall reschedule-fn)))) + + +;;; `decline_noun' card type ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +(defvar org-drill-noun-gender-alist + '(("masculine" "dodgerblue") + ("masc" "dodgerblue") + ("male" "dodgerblue") + ("m" "dodgerblue") + ("feminine" "orchid") + ("fem" "orchid") + ("female" "orchid") + ("f" "orchid") + ("neuter" "green") + ("neutral" "green") + ("neut" "green") + ("n" "green") + )) + + +(defun org-drill-get-noun-info () + "Auxiliary function used by `org-drill-present-noun-declension' and +`org-drill-show-answer-noun-declension'." + (let ((noun (org-entry-get (point) "NOUN" t)) + (noun-hint (org-entry-get (point) "NOUN_HINT" t)) + (noun-root (org-entry-get (point) "NOUN_ROOT" t)) + (noun-gender (org-entry-get (point) "NOUN_GENDER" t)) + (translation (org-entry-get (point) "NOUN_TRANSLATION" t)) + (highlight-face nil)) + (unless (and noun translation) + (error "Missing information for `decline_noun' card (%s, %s, %s, %s) at %s" + noun translation noun-hint noun-root (point))) + (setq noun-root (if noun-root (car (read-from-string noun-root))) + noun (car (read-from-string noun)) + noun-gender (downcase (car (read-from-string noun-gender))) + noun-hint (if noun-hint (car (read-from-string noun-hint))) + translation (car (read-from-string translation))) + (setq highlight-face + (list :foreground + (or (second (assoc-string noun-gender + org-drill-noun-gender-alist t)) + "red"))) + (setq noun (propertize noun 'face highlight-face)) + (setq translation (propertize translation 'face highlight-face)) + (list noun noun-root noun-gender noun-hint translation))) + + +(defun org-drill-present-noun-declension () + "Present a drill entry whose card type is 'decline_noun'." + (destructuring-bind (noun noun-root noun-gender noun-hint translation) + (org-drill-get-noun-info) + (let* ((props (org-entry-properties (point))) + (definite + (cond + ((assoc "DECLINE_DEFINITE" props) + (propertize (if (org-entry-get (point) "DECLINE_DEFINITE") + "definite" "indefinite") + 'face 'warning)) + (t nil))) + (plural + (cond + ((assoc "DECLINE_PLURAL" props) + (propertize (if (org-entry-get (point) "DECLINE_PLURAL") + "plural" "singular") + 'face 'warning)) + (t nil)))) + (org-drill-present-card-using-text + (cond + ((zerop (random* 2)) + (format "\nTranslate the noun\n\n%s (%s)\n\nand list its declensions%s.\n\n" + noun noun-gender + (if (or plural definite) + (format " for the %s %s form" definite plural) + ""))) + (t + (format "\nGive the noun that means\n\n%s %s\n +and list its declensions%s.\n\n" + translation + (if noun-hint (format " [HINT: %s]" noun-hint) "") + (if (or plural definite) + (format " for the %s %s form" definite plural) + "")))))))) + + +(defun org-drill-show-answer-noun-declension (reschedule-fn) + "Show the answer for a drill item whose card type is 'decline_noun'. +RESCHEDULE-FN must be a function that calls `org-drill-reschedule' and +returns its return value." + (destructuring-bind (noun noun-root noun-gender noun-hint translation) + (org-drill-get-noun-info) + (with-replaced-entry-heading + (format "Declensions of %s (%s) ==> %s\n\n" + noun noun-gender translation) + (org-cycle-hide-drawers 'all) (funcall reschedule-fn)))) ;;; `translate_number' card type ============================================== ;;; See spanish.org for usage -(defvar *drilled-number* 0) -(defvar *drilled-number-direction* 'to-english) + +(defun spelln-integer-in-language (n lang) + (let ((spelln-language lang)) + (spelln-integer-in-words n))) (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))) + (drilled-number 0) + (drilled-number-direction 'to-english) (highlight-face 'font-lock-warning-face)) (cond ((not (fboundp 'spelln-integer-in-words)) @@ -2908,46 +2894,48 @@ returns its return value." (if (> num-min num-max) (psetf num-min num-max num-max num-min)) - (setq *drilled-number* + (setq drilled-number (+ num-min (random* (abs (1+ (- num-max num-min)))))) - (setq *drilled-number-direction* + (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))) + (cond + ((eql 'to-english drilled-number-direction) + (org-drill-present-card-using-text + (format "\nTranslate into English:\n\n%s\n" + (propertize + (spelln-integer-in-language drilled-number language) + 'face highlight-face)) + (spelln-integer-in-language drilled-number 'english-gb))) + (t + (org-drill-present-card-using-text (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)))) + (propertize + (spelln-integer-in-language drilled-number 'english-gb) + 'face highlight-face)) + (spelln-integer-in-language drilled-number language)))))))) + +;; (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 ================================================== diff --git a/contrib/lisp/org-e-beamer.el b/contrib/lisp/org-e-beamer.el deleted file mode 100644 index 0c3c430..0000000 --- a/contrib/lisp/org-e-beamer.el +++ /dev/null @@ -1,1069 +0,0 @@ -;;; 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-html.el b/contrib/lisp/org-e-html.el deleted file mode 100644 index f0ba5f9..0000000 --- a/contrib/lisp/org-e-html.el +++ /dev/null @@ -1,3044 +0,0 @@ -;;; 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 deleted file mode 100644 index 8712f5a..0000000 --- a/contrib/lisp/org-e-latex.el +++ /dev/null @@ -1,2726 +0,0 @@ -;;; org-e-latex.el --- LaTeX Back-End For Org Export Engine - -;; Copyright (C) 2011-2012 Free Software Foundation, Inc. - -;; Author: Nicolas Goaziou <n.goaziou at gmail dot com> -;; Keywords: outlines, hypermedia, calendar, wp - -;; This program is free software; you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; This program is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with this program. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: -;; -;; This library implements a LaTeX back-end for Org generic exporter. -;; -;; To test it, run -;; -;; M-: (org-export-to-buffer 'e-latex "*Test e-LaTeX*") RET -;; -;; in an org-mode buffer then switch to the buffer to see the LaTeX -;; export. See contrib/lisp/org-export.el for more details on how -;; this exporter works. -;; -;; It introduces three new buffer keywords: "LATEX_CLASS", -;; "LATEX_CLASS_OPTIONS" and "LATEX_HEADER". - -;;; Code: - -(eval-when-compile (require 'cl)) -(require 'org-export) - -(defvar org-export-latex-default-packages-alist) -(defvar org-export-latex-packages-alist) -(defvar orgtbl-exp-regexp) - - - -;;; Define Back-End - -(org-export-define-backend e-latex - ((bold . org-e-latex-bold) - (center-block . org-e-latex-center-block) - (clock . org-e-latex-clock) - (code . org-e-latex-code) - (drawer . org-e-latex-drawer) - (dynamic-block . org-e-latex-dynamic-block) - (entity . org-e-latex-entity) - (example-block . org-e-latex-example-block) - (export-block . org-e-latex-export-block) - (export-snippet . org-e-latex-export-snippet) - (fixed-width . org-e-latex-fixed-width) - (footnote-definition . org-e-latex-footnote-definition) - (footnote-reference . org-e-latex-footnote-reference) - (headline . org-e-latex-headline) - (horizontal-rule . org-e-latex-horizontal-rule) - (inline-src-block . org-e-latex-inline-src-block) - (inlinetask . org-e-latex-inlinetask) - (italic . org-e-latex-italic) - (item . org-e-latex-item) - (keyword . org-e-latex-keyword) - (latex-environment . org-e-latex-latex-environment) - (latex-fragment . org-e-latex-latex-fragment) - (line-break . org-e-latex-line-break) - (link . org-e-latex-link) - (macro . org-e-latex-macro) - (paragraph . org-e-latex-paragraph) - (plain-list . org-e-latex-plain-list) - (plain-text . org-e-latex-plain-text) - (planning . org-e-latex-planning) - (property-drawer . org-e-latex-property-drawer) - (quote-block . org-e-latex-quote-block) - (quote-section . org-e-latex-quote-section) - (radio-target . org-e-latex-radio-target) - (section . org-e-latex-section) - (special-block . org-e-latex-special-block) - (src-block . org-e-latex-src-block) - (statistics-cookie . org-e-latex-statistics-cookie) - (strike-through . org-e-latex-strike-through) - (subscript . org-e-latex-subscript) - (superscript . org-e-latex-superscript) - (table . org-e-latex-table) - (table-cell . org-e-latex-table-cell) - (table-row . org-e-latex-table-row) - (target . org-e-latex-target) - (template . org-e-latex-template) - (timestamp . org-e-latex-timestamp) - (underline . org-e-latex-underline) - (verbatim . org-e-latex-verbatim) - (verse-block . org-e-latex-verse-block)) - :export-block "LATEX" - :options-alist ((:date "DATE" nil org-e-latex-date-format t) - (:latex-class "LATEX_CLASS" nil org-e-latex-default-class t) - (:latex-class-options "LATEX_CLASS_OPTIONS" nil nil t) - (:latex-header-extra "LATEX_HEADER" nil nil newline))) - - - -;;; Internal Variables - -(defconst org-e-latex-babel-language-alist - '(("af" . "afrikaans") - ("bg" . "bulgarian") - ("bt-br" . "brazilian") - ("ca" . "catalan") - ("cs" . "czech") - ("cy" . "welsh") - ("da" . "danish") - ("de" . "germanb") - ("de-at" . "naustrian") - ("de-de" . "ngerman") - ("el" . "greek") - ("en" . "english") - ("en-au" . "australian") - ("en-ca" . "canadian") - ("en-gb" . "british") - ("en-ie" . "irish") - ("en-nz" . "newzealand") - ("en-us" . "american") - ("es" . "spanish") - ("et" . "estonian") - ("eu" . "basque") - ("fi" . "finnish") - ("fr" . "frenchb") - ("fr-ca" . "canadien") - ("gl" . "galician") - ("hr" . "croatian") - ("hu" . "hungarian") - ("id" . "indonesian") - ("is" . "icelandic") - ("it" . "italian") - ("la" . "latin") - ("ms" . "malay") - ("nl" . "dutch") - ("no-no" . "nynorsk") - ("pl" . "polish") - ("pt" . "portuguese") - ("ro" . "romanian") - ("ru" . "russian") - ("sa" . "sanskrit") - ("sb" . "uppersorbian") - ("sk" . "slovak") - ("sl" . "slovene") - ("sq" . "albanian") - ("sr" . "serbian") - ("sv" . "swedish") - ("ta" . "tamil") - ("tr" . "turkish") - ("uk" . "ukrainian")) - "Alist between language code and corresponding Babel option.") - - - -;;; User Configurable Variables - -(defgroup org-export-e-latex nil - "Options for exporting Org mode files to LaTeX." - :tag "Org Export LaTeX" - :group 'org-export) - - -;;;; Preamble - -(defcustom org-e-latex-default-class "article" - "The default LaTeX class." - :group 'org-export-e-latex - :type '(string :tag "LaTeX class")) - -(defcustom org-e-latex-classes - '(("article" - "\\documentclass[11pt]{article}" - ("\\section{%s}" . "\\section*{%s}") - ("\\subsection{%s}" . "\\subsection*{%s}") - ("\\subsubsection{%s}" . "\\subsubsection*{%s}") - ("\\paragraph{%s}" . "\\paragraph*{%s}") - ("\\subparagraph{%s}" . "\\subparagraph*{%s}")) - ("report" - "\\documentclass[11pt]{report}" - ("\\part{%s}" . "\\part*{%s}") - ("\\chapter{%s}" . "\\chapter*{%s}") - ("\\section{%s}" . "\\section*{%s}") - ("\\subsection{%s}" . "\\subsection*{%s}") - ("\\subsubsection{%s}" . "\\subsubsection*{%s}")) - ("book" - "\\documentclass[11pt]{book}" - ("\\part{%s}" . "\\part*{%s}") - ("\\chapter{%s}" . "\\chapter*{%s}") - ("\\section{%s}" . "\\section*{%s}") - ("\\subsection{%s}" . "\\subsection*{%s}") - ("\\subsubsection{%s}" . "\\subsubsection*{%s}"))) - "Alist of LaTeX classes and associated header and structure. -If #+LaTeX_CLASS is set in the buffer, use its value and the -associated information. Here is the structure of each cell: - - \(class-name - header-string - \(numbered-section . unnumbered-section\) - ...\) - -The header string ------------------ - -The HEADER-STRING is the header that will be inserted into the -LaTeX file. It should contain the \\documentclass macro, and -anything else that is needed for this setup. To this header, the -following commands will be added: - -- Calls to \\usepackage for all packages mentioned in the - variables `org-export-latex-default-packages-alist' and - `org-export-latex-packages-alist'. Thus, your header - definitions should avoid to also request these packages. - -- Lines specified via \"#+LaTeX_HEADER:\" - -If you need more control about the sequence in which the header -is built up, or if you want to exclude one of these building -blocks for a particular class, you can use the following -macro-like placeholders. - - [DEFAULT-PACKAGES] \\usepackage statements for default packages - [NO-DEFAULT-PACKAGES] do not include any of the default packages - [PACKAGES] \\usepackage statements for packages - [NO-PACKAGES] do not include the packages - [EXTRA] the stuff from #+LaTeX_HEADER - [NO-EXTRA] do not include #+LaTeX_HEADER stuff - -So a header like - - \\documentclass{article} - [NO-DEFAULT-PACKAGES] - [EXTRA] - \\providecommand{\\alert}[1]{\\textbf{#1}} - [PACKAGES] - -will omit the default packages, and will include the -#+LaTeX_HEADER lines, then have a call to \\providecommand, and -then place \\usepackage commands based on the content of -`org-export-latex-packages-alist'. - -If your header, `org-export-latex-default-packages-alist' or -`org-export-latex-packages-alist' inserts -\"\\usepackage[AUTO]{inputenc}\", AUTO will automatically be -replaced with a coding system derived from -`buffer-file-coding-system'. See also the variable -`org-e-latex-inputenc-alist' for a way to influence this -mechanism. - -The sectioning structure ------------------------- - -The sectioning structure of the class is given by the elements -following the header string. For each sectioning level, a number -of strings is specified. A %s formatter is mandatory in each -section string and will be replaced by the title of the section. - -Instead of a cons cell \(numbered . unnumbered\), you can also -provide a list of 2 or 4 elements, - - \(numbered-open numbered-close\) - -or - - \(numbered-open numbered-close unnumbered-open unnumbered-close\) - -providing opening and closing strings for a LaTeX environment -that should represent the document section. The opening clause -should have a %s to represent the section title. - -Instead of a list of sectioning commands, you can also specify -a function name. That function will be called with two -parameters, the \(reduced) level of the headline, and a predicate -non-nil when the headline should be numbered. It must return -a format string in which the section title will be added." - :group 'org-export-e-latex - :type '(repeat - (list (string :tag "LaTeX class") - (string :tag "LaTeX header") - (repeat :tag "Levels" :inline t - (choice - (cons :tag "Heading" - (string :tag " numbered") - (string :tag "unnumbered")) - (list :tag "Environment" - (string :tag "Opening (numbered)") - (string :tag "Closing (numbered)") - (string :tag "Opening (unnumbered)") - (string :tag "Closing (unnumbered)")) - (function :tag "Hook computing sectioning")))))) - -(defcustom org-e-latex-inputenc-alist nil - "Alist of inputenc coding system names, and what should really be used. -For example, adding an entry - - (\"utf8\" . \"utf8x\") - -will cause \\usepackage[utf8x]{inputenc} to be used for buffers that -are written as utf8 files." - :group 'org-export-e-latex - :type '(repeat - (cons - (string :tag "Derived from buffer") - (string :tag "Use this instead")))) - -(defcustom org-e-latex-date-format - "\\today" - "Format string for \\date{...}." - :group 'org-export-e-latex - :type 'boolean) - -(defcustom org-e-latex-title-command "\\maketitle" - "The command used to insert the title just after \\begin{document}. -If this string contains the formatting specification \"%s\" then -it will be used as a formatting string, passing the title as an -argument." - :group 'org-export-e-latex - :type 'string) - - -;;;; Headline - -(defcustom org-e-latex-format-headline-function nil - "Function to format headline text. - -This function will be called with 5 arguments: -TODO the todo keyword (string or nil). -TODO-TYPE the type of todo (symbol: `todo', `done', nil) -PRIORITY the priority of the headline (integer or nil) -TEXT the main headline text (string). -TAGS the tags as a list of strings (list of strings or nil). - -The function result will be used in the section format string. - -As an example, one could set the variable to the following, in -order to reproduce the default set-up: - -\(defun org-e-latex-format-headline (todo todo-type priority text tags) - \"Default format function for an headline.\" - \(concat (when todo - \(format \"\\\\textbf{\\\\textsc{\\\\textsf{%s}}} \" todo)) - \(when priority - \(format \"\\\\framebox{\\\\#%c} \" priority)) - text - \(when tags - \(format \"\\\\hfill{}\\\\textsc{%s}\" - \(mapconcat 'identity tags \":\"))))" - :group 'org-export-e-latex - :type 'function) - - -;;;; Footnotes - -(defcustom org-e-latex-footnote-separator "\\textsuperscript{,}\\," - "Text used to separate footnotes." - :group 'org-export-e-latex - :type 'string) - - -;;;; Timestamps - -(defcustom org-e-latex-active-timestamp-format "\\textit{%s}" - "A printf format string to be applied to active timestamps." - :group 'org-export-e-latex - :type 'string) - -(defcustom org-e-latex-inactive-timestamp-format "\\textit{%s}" - "A printf format string to be applied to inactive timestamps." - :group 'org-export-e-latex - :type 'string) - -(defcustom org-e-latex-diary-timestamp-format "\\textit{%s}" - "A printf format string to be applied to diary timestamps." - :group 'org-export-e-latex - :type 'string) - - -;;;; Links - -(defcustom org-e-latex-image-default-option "width=.9\\linewidth" - "Default option for images." - :group 'org-export-e-latex - :type 'string) - -(defcustom org-e-latex-default-figure-position "htb" - "Default position for latex figures." - :group 'org-export-e-latex - :type 'string) - -(defcustom org-e-latex-inline-image-rules - '(("file" . "\\.\\(pdf\\|jpeg\\|jpg\\|png\\|ps\\|eps\\)\\'")) - "Rules characterizing image files that can be inlined into LaTeX. - -A rule consists in an association whose key is the type of link -to consider, and value is a regexp that will be matched against -link's path. - -Note that, by default, the image extension *actually* allowed -depend on the way the LaTeX file is processed. When used with -pdflatex, pdf, jpg and png images are OK. When processing -through dvi to Postscript, only ps and eps are allowed. The -default we use here encompasses both." - :group 'org-export-e-latex - :type '(alist :key-type (string :tag "Type") - :value-type (regexp :tag "Path"))) - -(defcustom org-e-latex-link-with-unknown-path-format "\\texttt{%s}" - "Format string for links with unknown path type." - :group 'org-export-latex - :type 'string) - - -;;;; Tables - -(defcustom org-e-latex-default-table-environment "tabular" - "Default environment used to build tables." - :group 'org-export-e-latex - :type 'string) - -(defcustom org-e-latex-tables-centered t - "When non-nil, tables are exported in a center environment." - :group 'org-export-e-latex - :type 'boolean) - -(defcustom org-e-latex-tables-verbatim nil - "When non-nil, tables are exported verbatim." - :group 'org-export-e-latex - :type 'boolean) - -(defcustom org-e-latex-tables-booktabs nil - "When non-nil, display tables in a formal \"booktabs\" style. -This option assumes that the \"booktabs\" package is properly -loaded in the header of the document. This value can be ignored -locally with \"booktabs=yes\" and \"booktabs=no\" LaTeX -attributes." - :group 'org-export-e-latex - :type 'boolean) - -(defcustom org-e-latex-table-caption-above t - "When non-nil, place caption string at the beginning of the table. -Otherwise, place it near the end." - :group 'org-export-e-latex - :type 'boolean) - -(defcustom org-e-latex-table-scientific-notation "%s\\,(%s)" - "Format string to display numbers in scientific notation. -The format should have \"%s\" twice, for mantissa and exponent -\(i.e. \"%s\\\\times10^{%s}\"). - -When nil, no transformation is made." - :group 'org-export-e-latex - :type '(choice - (string :tag "Format string") - (const :tag "No formatting"))) - - -;;;; Text markup - -(defcustom org-e-latex-text-markup-alist '((bold . "\\textbf{%s}") - (code . verb) - (italic . "\\emph{%s}") - (strike-through . "\\st{%s}") - (underline . "\\underline{%s}") - (verbatim . protectedtexttt)) - "Alist of LaTeX expressions to convert text markup. - -The key must be a symbol among `bold', `code', `italic', -`strike-through', `underline' and `verbatim'. The value is -a formatting string to wrap fontified text with. - -Value can also be set to the following symbols: `verb' and -`protectedtexttt'. For the former, Org will use \"\\verb\" to -create a format string and select a delimiter character that -isn't in the string. For the latter, Org will use \"\\texttt\" -to typeset and try to protect special characters. - -If no association can be found for a given markup, text will be -returned as-is." - :group 'org-export-e-latex - :type 'alist - :options '(bold code italic strike-through underline verbatim)) - - -;;;; Drawers - -(defcustom org-e-latex-format-drawer-function nil - "Function called to format a drawer in LaTeX code. - -The function must accept two parameters: - NAME the drawer name, like \"LOGBOOK\" - CONTENTS the contents of the drawer. - -The function should return the string to be exported. - -For example, the variable could be set to the following function -in order to mimic default behaviour: - -\(defun org-e-latex-format-drawer-default \(name contents\) - \"Format a drawer element for LaTeX export.\" - contents\)" - :group 'org-export-e-latex - :type 'function) - - -;;;; Inlinetasks - -(defcustom org-e-latex-format-inlinetask-function nil - "Function called to format an inlinetask in LaTeX code. - -The function must accept six parameters: - TODO the todo keyword, as a string - TODO-TYPE the todo type, a symbol among `todo', `done' and nil. - PRIORITY the inlinetask priority, as a string - NAME the inlinetask name, as a string. - TAGS the inlinetask tags, as a list of strings. - CONTENTS the contents of the inlinetask, as a string. - -The function should return the string to be exported. - -For example, the variable could be set to the following function -in order to mimic default behaviour: - -\(defun org-e-latex-format-inlinetask \(todo type priority name tags contents\) -\"Format an inline task element for LaTeX export.\" - \(let ((full-title - \(concat - \(when todo - \(format \"\\\\textbf{\\\\textsf{\\\\textsc{%s}}} \" todo)) - \(when priority (format \"\\\\framebox{\\\\#%c} \" priority)) - title - \(when tags - \(format \"\\\\hfill{}\\\\textsc{:%s:}\" - \(mapconcat 'identity tags \":\"))))) - \(format (concat \"\\\\begin{center}\\n\" - \"\\\\fbox{\\n\" - \"\\\\begin{minipage}[c]{.6\\\\textwidth}\\n\" - \"%s\\n\\n\" - \"\\\\rule[.8em]{\\\\textwidth}{2pt}\\n\\n\" - \"%s\" - \"\\\\end{minipage}}\" - \"\\\\end{center}\") - full-title contents))" - :group 'org-export-e-latex - :type 'function) - - -;; Src blocks - -(defcustom org-e-latex-listings nil - "Non-nil means export source code using the listings package. -This package will fontify source code, possibly even with color. -If you want to use this, you also need to make LaTeX use the -listings package, and if you want to have color, the color -package. Just add these to `org-export-latex-packages-alist', -for example using customize, or with something like: - - \(require 'org-e-latex) - \(add-to-list 'org-export-latex-packages-alist '\(\"\" \"listings\")) - \(add-to-list 'org-export-latex-packages-alist '\(\"\" \"color\")) - -Alternatively, - - \(setq org-e-latex-listings 'minted) - -causes source code to be exported using the minted package as -opposed to listings. If you want to use minted, you need to add -the minted package to `org-export-latex-packages-alist', for -example using customize, or with - - \(require 'org-e-latex) - \(add-to-list 'org-export-latex-packages-alist '\(\"\" \"minted\")) - -In addition, it is necessary to install pygments -\(http://pygments.org), and to configure the variable -`org-e-latex-pdf-process' so that the -shell-escape option is -passed to pdflatex." - :group 'org-export-e-latex - :type '(choice - (const :tag "Use listings" t) - (const :tag "Use minted" 'minted) - (const :tag "Export verbatim" nil))) - -(defcustom org-e-latex-listings-langs - '((emacs-lisp "Lisp") (lisp "Lisp") (clojure "Lisp") - (c "C") (cc "C++") - (fortran "fortran") - (perl "Perl") (cperl "Perl") (python "Python") (ruby "Ruby") - (html "HTML") (xml "XML") - (tex "TeX") (latex "TeX") - (shell-script "bash") - (gnuplot "Gnuplot") - (ocaml "Caml") (caml "Caml") - (sql "SQL") (sqlite "sql")) - "Alist mapping languages to their listing language counterpart. -The key is a symbol, the major mode symbol without the \"-mode\". -The value is the string that should be inserted as the language -parameter for the listings package. If the mode name and the -listings name are the same, the language does not need an entry -in this list - but it does not hurt if it is present." - :group 'org-export-e-latex - :type '(repeat - (list - (symbol :tag "Major mode ") - (string :tag "Listings language")))) - -(defcustom org-e-latex-listings-options nil - "Association list of options for the latex listings package. - -These options are supplied as a comma-separated list to the -\\lstset command. Each element of the association list should be -a list containing two strings: the name of the option, and the -value. For example, - - (setq org-e-latex-listings-options - '((\"basicstyle\" \"\\small\") - (\"keywordstyle\" \"\\color{black}\\bfseries\\underbar\"))) - -will typeset the code in a small size font with underlined, bold -black keywords. - -Note that the same options will be applied to blocks of all -languages." - :group 'org-export-e-latex - :type '(repeat - (list - (string :tag "Listings option name ") - (string :tag "Listings option value")))) - -(defcustom org-e-latex-minted-langs - '((emacs-lisp "common-lisp") - (cc "c++") - (cperl "perl") - (shell-script "bash") - (caml "ocaml")) - "Alist mapping languages to their minted language counterpart. -The key is a symbol, the major mode symbol without the \"-mode\". -The value is the string that should be inserted as the language -parameter for the minted package. If the mode name and the -listings name are the same, the language does not need an entry -in this list - but it does not hurt if it is present. - -Note that minted uses all lower case for language identifiers, -and that the full list of language identifiers can be obtained -with: - - pygmentize -L lexers" - :group 'org-export-e-latex - :type '(repeat - (list - (symbol :tag "Major mode ") - (string :tag "Minted language")))) - -(defcustom org-e-latex-minted-options nil - "Association list of options for the latex minted package. - -These options are supplied within square brackets in -\\begin{minted} environments. Each element of the alist should -be a list containing two strings: the name of the option, and the -value. For example, - - \(setq org-e-latex-minted-options - '\((\"bgcolor\" \"bg\") \(\"frame\" \"lines\"))) - -will result in src blocks being exported with - -\\begin{minted}[bgcolor=bg,frame=lines]{<LANG>} - -as the start of the minted environment. Note that the same -options will be applied to blocks of all languages." - :group 'org-export-e-latex - :type '(repeat - (list - (string :tag "Minted option name ") - (string :tag "Minted option value")))) - -(defvar org-e-latex-custom-lang-environments nil - "Alist mapping languages to language-specific LaTeX environments. - -It is used during export of src blocks by the listings and minted -latex packages. For example, - - \(setq org-e-latex-custom-lang-environments - '\(\(python \"pythoncode\"\)\)\) - -would have the effect that if org encounters begin_src python -during latex export it will output - - \\begin{pythoncode} - <src block body> - \\end{pythoncode}") - - -;;;; Plain text - -(defcustom org-e-latex-quotes - '(("fr" - ("\\(\\s-\\|[[(]\\|^\\)\"" . "«~") - ("\\(\\S-\\)\"" . "~»") - ("\\(\\s-\\|(\\|^\\)'" . "'")) - ("en" - ("\\(\\s-\\|[[(]\\|^\\)\"" . "``") - ("\\(\\S-\\)\"" . "''") - ("\\(\\s-\\|(\\|^\\)'" . "`"))) - "Alist for quotes to use when converting english double-quotes. - -The CAR of each item in this alist is the language code. -The CDR of each item in this alist is a list of three CONS: -- the first CONS defines the opening quote; -- the second CONS defines the closing quote; -- the last CONS defines single quotes. - -For each item in a CONS, the first string is a regexp -for allowed characters before/after the quote, the second -string defines the replacement string for this quote." - :group 'org-export-e-latex - :type '(list - (cons :tag "Opening quote" - (string :tag "Regexp for char before") - (string :tag "Replacement quote ")) - (cons :tag "Closing quote" - (string :tag "Regexp for char after ") - (string :tag "Replacement quote ")) - (cons :tag "Single quote" - (string :tag "Regexp for char before") - (string :tag "Replacement quote ")))) - - -;;;; Compilation - -(defcustom org-e-latex-pdf-process - '("pdflatex -interaction nonstopmode -output-directory %o %f" - "pdflatex -interaction nonstopmode -output-directory %o %f" - "pdflatex -interaction nonstopmode -output-directory %o %f") - "Commands to process a LaTeX file to a PDF file. -This is a list of strings, each of them will be given to the -shell as a command. %f in the command will be replaced by the -full file name, %b by the file base name \(i.e. without -extension) and %o by the base directory of the file. - -The reason why this is a list is that it usually takes several -runs of `pdflatex', maybe mixed with a call to `bibtex'. Org -does not have a clever mechanism to detect which of these -commands have to be run to get to a stable result, and it also -does not do any error checking. - -By default, Org uses 3 runs of `pdflatex' to do the processing. -If you have texi2dvi on your system and if that does not cause -the infamous egrep/locale bug: - - http://lists.gnu.org/archive/html/bug-texinfo/2010-03/msg00031.html - -then `texi2dvi' is the superior choice. Org does offer it as one -of the customize options. - -Alternatively, this may be a Lisp function that does the -processing, so you could use this to apply the machinery of -AUCTeX or the Emacs LaTeX mode. This function should accept the -file name as its single argument." - :group 'org-export-pdf - :type '(choice - (repeat :tag "Shell command sequence" - (string :tag "Shell command")) - (const :tag "2 runs of pdflatex" - ("pdflatex -interaction nonstopmode -output-directory %o %f" - "pdflatex -interaction nonstopmode -output-directory %o %f")) - (const :tag "3 runs of pdflatex" - ("pdflatex -interaction nonstopmode -output-directory %o %f" - "pdflatex -interaction nonstopmode -output-directory %o %f" - "pdflatex -interaction nonstopmode -output-directory %o %f")) - (const :tag "pdflatex,bibtex,pdflatex,pdflatex" - ("pdflatex -interaction nonstopmode -output-directory %o %f" - "bibtex %b" - "pdflatex -interaction nonstopmode -output-directory %o %f" - "pdflatex -interaction nonstopmode -output-directory %o %f")) - (const :tag "texi2dvi" - ("texi2dvi -p -b -c -V %f")) - (const :tag "rubber" - ("rubber -d --into %o %f")) - (function))) - -(defcustom org-e-latex-logfiles-extensions - '("aux" "idx" "log" "out" "toc" "nav" "snm" "vrb") - "The list of file extensions to consider as LaTeX logfiles." - :group 'org-export-e-latex - :type '(repeat (string :tag "Extension"))) - -(defcustom org-e-latex-remove-logfiles t - "Non-nil means remove the logfiles produced by PDF production. -These are the .aux, .log, .out, and .toc files." - :group 'org-export-e-latex - :type 'boolean) - - - -;;; Internal Functions - -(defun org-e-latex--caption/label-string (caption label info) - "Return caption and label LaTeX string for floats. - -CAPTION is a cons cell of secondary strings, the car being the -standard caption and the cdr its short form. LABEL is a string -representing the label. INFO is a plist holding contextual -information. - -If there's no caption nor label, return the empty string. - -For non-floats, see `org-e-latex--wrap-label'." - (let ((label-str (if label (format "\\label{%s}" label) ""))) - (cond - ((and (not caption) (not label)) "") - ((not caption) (format "\\label{%s}\n" label)) - ;; Option caption format with short name. - ((cdr caption) - (format "\\caption[%s]{%s%s}\n" - (org-export-data (cdr caption) info) - label-str - (org-export-data (car caption) info))) - ;; Standard caption format. - (t (format "\\caption{%s%s}\n" - label-str - (org-export-data (car caption) info)))))) - -(defun org-e-latex--guess-babel-language (header info) - "Set Babel's language according to LANGUAGE keyword. - -HEADER is the LaTeX header string. INFO is the plist used as -a communication channel. - -Insertion of guessed language only happens when Babel package has -explicitly been loaded. Then it is added to the rest of -package's options. - -Return the new header." - (let ((language-code (plist-get info :language))) - ;; If no language is set or Babel package is not loaded, return - ;; HEADER as-is. - (if (or (not (stringp language-code)) - (not (string-match "\\\\usepackage\\[\\(.*\\)\\]{babel}" header))) - header - (let ((options (save-match-data - (org-split-string (match-string 1 header) ","))) - (language (cdr (assoc language-code - org-e-latex-babel-language-alist)))) - ;; If LANGUAGE is already loaded, return header. Otherwise, - ;; append LANGUAGE to other options. - (if (member language options) header - (replace-match (mapconcat 'identity - (append options (list language)) - ",") - nil nil header 1)))))) - -(defun org-e-latex--guess-inputenc (header) - "Set the coding system in inputenc to what the buffer is. -HEADER is the LaTeX header string. Return the new header." - (let* ((cs (or (ignore-errors - (latexenc-coding-system-to-inputenc - buffer-file-coding-system)) - "utf8"))) - (if (not cs) header - ;; First translate if that is requested. - (setq cs (or (cdr (assoc cs org-e-latex-inputenc-alist)) cs)) - ;; Then find the \usepackage statement and replace the option. - (replace-regexp-in-string "\\\\usepackage\\[\\(AUTO\\)\\]{inputenc}" - cs header t nil 1)))) - -(defun org-e-latex--find-verb-separator (s) - "Return a character not used in string S. -This is used to choose a separator for constructs like \\verb." - (let ((ll "~,./?;':\"|!@#%^&-_=+abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ<>()[]{}")) - (loop for c across ll - when (not (string-match (regexp-quote (char-to-string c)) s)) - return (char-to-string c)))) - -(defun org-e-latex--make-option-string (options) - "Return a comma separated string of keywords and values. -OPTIONS is an alist where the key is the options keyword as -a string, and the value a list containing the keyword value, or -nil." - (mapconcat (lambda (pair) - (concat (first pair) - (when (> (length (second pair)) 0) - (concat "=" (second pair))))) - options - ",")) - -(defun org-e-latex--quotation-marks (text info) - "Export quotation marks depending on language conventions. -TEXT is a string containing quotation marks to be replaced. INFO -is a plist used as a communication channel." - (mapc (lambda(l) - (let ((start 0)) - (while (setq start (string-match (car l) text start)) - (let ((new-quote (concat (match-string 1 text) (cdr l)))) - (setq text (replace-match new-quote t t text)))))) - (cdr (or (assoc (plist-get info :language) org-e-latex-quotes) - ;; Falls back on English. - (assoc "en" org-e-latex-quotes)))) - text) - -(defun org-e-latex--wrap-label (element output) - "Wrap label associated to ELEMENT around OUTPUT, if appropriate. -This function shouldn't be used for floats. See -`org-e-latex--caption/label-string'." - (let ((label (org-element-property :name element))) - (if (or (not output) (not label) (string= output "") (string= label "")) - output - (concat (format "\\label{%s}\n" label) output)))) - -(defun org-e-latex--text-markup (text markup) - "Format TEXT depending on MARKUP text markup. -See `org-e-latex-text-markup-alist' for details." - (let ((fmt (cdr (assq markup org-e-latex-text-markup-alist)))) - (cond - ;; No format string: Return raw text. - ((not fmt) text) - ;; Handle the `verb' special case: Find and appropriate separator - ;; and use "\\verb" command. - ((eq 'verb fmt) - (let ((separator (org-e-latex--find-verb-separator text))) - (concat "\\verb" separator text separator))) - ;; Handle the `protectedtexttt' special case: Protect some - ;; special chars and use "\texttt{%s}" format string. - ((eq 'protectedtexttt fmt) - (let ((start 0) - (trans '(("\\" . "\\textbackslash{}") - ("~" . "\\textasciitilde{}") - ("^" . "\\textasciicircum{}"))) - (rtn "") - char) - (while (string-match "[\\{}$%&_#~^]" text) - (setq char (match-string 0 text)) - (if (> (match-beginning 0) 0) - (setq rtn (concat rtn (substring text 0 (match-beginning 0))))) - (setq text (substring text (1+ (match-beginning 0)))) - (setq char (or (cdr (assoc char trans)) (concat "\\" char)) - rtn (concat rtn char))) - (setq text (concat rtn text) - fmt "\\texttt{%s}") - (while (string-match "--" text) - (setq text (replace-match "-{}-" t t text))) - (format fmt text))) - ;; Else use format string. - (t (format fmt text))))) - -(defun org-e-latex--delayed-footnotes-definitions (element info) - "Return footnotes definitions in ELEMENT as a string. - -INFO is a plist used as a communication channel. - -Footnotes definitions are returned within \"\\footnotetxt{}\" -commands. - -This function is used within constructs that don't support -\"\\footnote{}\" command (i.e. an item's tag). In that case, -\"\\footnotemark\" is used within the construct and the function -just outside of it." - (mapconcat - (lambda (ref) - (format - "\\footnotetext[%s]{%s}" - (org-export-get-footnote-number ref info) - (org-trim - (org-export-data - (org-export-get-footnote-definition ref info) info)))) - ;; Find every footnote reference in ELEMENT. - (let* (all-refs - search-refs ; For byte-compiler. - (search-refs - (function - (lambda (data) - ;; Return a list of all footnote references never seen - ;; before in DATA. - (org-element-map - data 'footnote-reference - (lambda (ref) - (when (org-export-footnote-first-reference-p ref info) - (push ref all-refs) - (when (eq (org-element-property :type ref) 'standard) - (funcall search-refs - (org-export-get-footnote-definition ref info))))) - info) - (reverse all-refs))))) - (funcall search-refs element)) - "")) - - - -;;; Template - -(defun org-e-latex-template (contents info) - "Return complete document string after LaTeX conversion. -CONTENTS is the transcoded contents string. INFO is a plist -holding export options." - (let ((title (org-export-data (plist-get info :title) info))) - (concat - ;; Time-stamp. - (and (plist-get info :time-stamp-file) - (format-time-string "%% Created %Y-%m-%d %a %H:%M\n")) - ;; Document class and packages. - (let ((class (plist-get info :latex-class)) - (class-options (plist-get info :latex-class-options))) - (org-element-normalize-string - (let* ((header (nth 1 (assoc class org-e-latex-classes))) - (document-class-string - (and (stringp header) - (if class-options - (replace-regexp-in-string - "^[ \t]*\\\\documentclass\\(\\[.*?\\]\\)" - class-options header t nil 1) - header)))) - (when document-class-string - (org-e-latex--guess-babel-language - (org-e-latex--guess-inputenc - (org-splice-latex-header - document-class-string - org-export-latex-default-packages-alist ; defined in org.el - org-export-latex-packages-alist nil ; defined in org.el - (plist-get info :latex-header-extra))) - info))))) - ;; Possibly limit depth for headline numbering. - (let ((sec-num (plist-get info :section-numbers))) - (when (integerp sec-num) - (format "\\setcounter{secnumdepth}{%d}\n" sec-num))) - ;; Author. - (let ((author (and (plist-get info :with-author) - (let ((auth (plist-get info :author))) - (and auth (org-export-data auth info))))) - (email (and (plist-get info :with-email) - (org-export-data (plist-get info :email) info)))) - (cond ((and author email (not (string= "" email))) - (format "\\author{%s\\thanks{%s}}\n" author email)) - (author (format "\\author{%s}\n" author)) - (t "\\author{}\n"))) - ;; Date. - (let ((date (org-export-data (plist-get info :date) info))) - (and date (format "\\date{%s}\n" date))) - ;; Title - (format "\\title{%s}\n" title) - ;; Hyperref options. - (format "\\hypersetup{\n pdfkeywords={%s},\n pdfsubject={%s},\n pdfcreator={%s}}\n" - (or (plist-get info :keywords) "") - (or (plist-get info :description) "") - (if (not (plist-get info :with-creator)) "" - (plist-get info :creator))) - ;; Document start. - "\\begin{document}\n\n" - ;; Title command. - (org-element-normalize-string - (cond ((string= "" title) nil) - ((not (stringp org-e-latex-title-command)) nil) - ((string-match "\\(?:[^%]\\|^\\)%s" - org-e-latex-title-command) - (format org-e-latex-title-command title)) - (t org-e-latex-title-command))) - ;; Table of contents. - (let ((depth (plist-get info :with-toc))) - (when depth - (concat (when (wholenump depth) - (format "\\setcounter{tocdepth}{%d}\n" depth)) - "\\tableofcontents\n\\vspace*{1cm}\n\n"))) - ;; Document's body. - contents - ;; Creator. - (let ((creator-info (plist-get info :with-creator))) - (cond - ((not creator-info) "") - ((eq creator-info 'comment) - (format "%% %s\n" (plist-get info :creator))) - (t (concat (plist-get info :creator) "\n")))) - ;; Document end. - "\\end{document}"))) - - - -;;; Transcode Functions - -;;;; Babel Call -;; -;; Babel Calls are ignored. - - -;;;; Bold - -(defun org-e-latex-bold (bold contents info) - "Transcode BOLD from Org to LaTeX. -CONTENTS is the text with bold markup. INFO is a plist holding -contextual information." - (org-e-latex--text-markup contents 'bold)) - - -;;;; Center Block - -(defun org-e-latex-center-block (center-block contents info) - "Transcode a CENTER-BLOCK element from Org to LaTeX. -CONTENTS holds the contents of the center block. INFO is a plist -holding contextual information." - (org-e-latex--wrap-label - center-block - (format "\\begin{center}\n%s\\end{center}" contents))) - - -;;;; Clock - -(defun org-e-latex-clock (clock contents info) - "Transcode a CLOCK element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual -information." - (concat - "\\noindent" - (format "\\textbf{%s} " org-clock-string) - (format org-e-latex-inactive-timestamp-format - (concat (org-translate-time (org-element-property :value clock)) - (let ((time (org-element-property :time clock))) - (and time (format " (%s)" time))))) - "\\\\")) - - -;;;; Code - -(defun org-e-latex-code (code contents info) - "Transcode a CODE object from Org to LaTeX. -CONTENTS is nil. INFO is a plist used as a communication -channel." - (org-e-latex--text-markup (org-element-property :value code) 'code)) - - -;;;; Comment -;; -;; Comments are ignored. - - -;;;; Comment Block -;; -;; Comment Blocks are ignored. - - -;;;; Drawer - -(defun org-e-latex-drawer (drawer contents info) - "Transcode a DRAWER element from Org to LaTeX. -CONTENTS holds the contents of the block. INFO is a plist -holding contextual information." - (let* ((name (org-element-property :drawer-name drawer)) - (output (if (functionp org-e-latex-format-drawer-function) - (funcall org-e-latex-format-drawer-function - name contents) - ;; If there's no user defined function: simply - ;; display contents of the drawer. - contents))) - (org-e-latex--wrap-label drawer output))) - - -;;;; Dynamic Block - -(defun org-e-latex-dynamic-block (dynamic-block contents info) - "Transcode a DYNAMIC-BLOCK element from Org to LaTeX. -CONTENTS holds the contents of the block. INFO is a plist -holding contextual information. See `org-export-data'." - (org-e-latex--wrap-label dynamic-block contents)) - - -;;;; Entity - -(defun org-e-latex-entity (entity contents info) - "Transcode an ENTITY object from Org to LaTeX. -CONTENTS are the definition itself. INFO is a plist holding -contextual information." - (let ((ent (org-element-property :latex entity))) - (if (org-element-property :latex-math-p entity) (format "$%s$" ent) ent))) - - -;;;; Example Block - -(defun org-e-latex-example-block (example-block contents info) - "Transcode an EXAMPLE-BLOCK element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual -information." - (org-e-latex--wrap-label - example-block - (format "\\begin{verbatim}\n%s\\end{verbatim}" - (org-export-format-code-default example-block info)))) - - -;;;; Export Block - -(defun org-e-latex-export-block (export-block contents info) - "Transcode a EXPORT-BLOCK element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - (when (string= (org-element-property :type export-block) "LATEX") - (org-remove-indentation (org-element-property :value export-block)))) - - -;;;; Export Snippet - -(defun org-e-latex-export-snippet (export-snippet contents info) - "Transcode a EXPORT-SNIPPET object from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - (when (eq (org-export-snippet-backend export-snippet) 'e-latex) - (org-element-property :value export-snippet))) - - -;;;; Fixed Width - -(defun org-e-latex-fixed-width (fixed-width contents info) - "Transcode a FIXED-WIDTH element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - (org-e-latex--wrap-label - fixed-width - (format "\\begin{verbatim}\n%s\\end{verbatim}" - (org-remove-indentation - (org-element-property :value fixed-width))))) - - -;;;; Footnote Definition -;; -;; Footnote Definitions are ignored. - - -;;;; Footnote Reference -;; -;; Footnote reference export is handled by -;; `org-e-latex-footnote-reference'. -;; -;; Internally, `org-e-latex--get-footnote-counter' is used to restore -;; the value of the LaTeX "footnote" counter after a jump due to -;; a reference to an already defined footnote. It is only needed in -;; item tags since the optional argument to \footnotemark is not -;; allowed there. - -(defun org-e-latex--get-footnote-counter (footnote-reference info) - "Return \"footnote\" counter before FOOTNOTE-REFERENCE is encountered. -INFO is a plist used as a communication channel." - ;; Find original counter value by counting number of footnote - ;; references appearing for the first time before the current - ;; footnote reference. - (let* ((label (org-element-property :label footnote-reference)) - seen-refs - search-ref ; For byte-compiler. - (search-ref - (function - (lambda (data) - ;; Search footnote references through DATA, filling - ;; SEEN-REFS along the way. - (org-element-map - data 'footnote-reference - (lambda (fn) - (let ((fn-lbl (org-element-property :label fn))) - (cond - ;; Anonymous footnote match: return number. - ((eq fn footnote-reference) (length seen-refs)) - ;; Anonymous footnote: it's always a new one. - ;; Also, be sure to return nil from the `cond' so - ;; `first-match' doesn't get us out of the loop. - ((not fn-lbl) (push 'inline seen-refs) nil) - ;; Label not seen so far: add it so SEEN-REFS. - ;; - ;; Also search for subsequent references in - ;; footnote definition so numbering follows reading - ;; logic. Note that we don't have to care about - ;; inline definitions, since `org-element-map' - ;; already traverse them at the right time. - ((not (member fn-lbl seen-refs)) - (push fn-lbl seen-refs) - (funcall search-ref - (org-export-get-footnote-definition fn info)))))) - ;; Don't enter footnote definitions since it will happen - ;; when their first reference is found. - info 'first-match 'footnote-definition))))) - (funcall search-ref (plist-get info :parse-tree)))) - -(defun org-e-latex-footnote-reference (footnote-reference contents info) - "Transcode a FOOTNOTE-REFERENCE element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - (concat - ;; Insert separator between two footnotes in a row. - (let ((prev (org-export-get-previous-element footnote-reference info))) - (when (eq (org-element-type prev) 'footnote-reference) - org-e-latex-footnote-separator)) - (cond - ;; Use \footnotemark if reference is within an item's tag. - ((eq (org-element-type (org-export-get-parent-element footnote-reference)) - 'item) - (if (org-export-footnote-first-reference-p footnote-reference info) - "\\footnotemark" - ;; Since we can't specify footnote number as an optional - ;; argument within an item tag, some extra work has to be done - ;; when the footnote has already been referenced. In that - ;; case, set footnote counter to the desired number, use the - ;; footnotemark, then set counter back to its original value. - (format - "\\setcounter{footnote}{%s}\\footnotemark\\setcounter{footnote}{%s}" - (1- (org-export-get-footnote-number footnote-reference info)) - (org-e-latex--get-footnote-counter footnote-reference info)))) - ;; Use \footnotemark if the footnote has already been defined. - ((not (org-export-footnote-first-reference-p footnote-reference info)) - (format "\\footnotemark[%s]{}" - (org-export-get-footnote-number footnote-reference info))) - ;; Use \footnotemark if reference is within another footnote - ;; reference or footnote definition. - ((loop for parent in (org-export-get-genealogy footnote-reference) - thereis (memq (org-element-type parent) - '(footnote-reference footnote-definition))) - "\\footnotemark") - ;; Otherwise, define it with \footnote command. - (t - (let ((def (org-export-get-footnote-definition footnote-reference info))) - (unless (eq (org-element-type def) 'org-data) - (setq def (cons 'org-data (cons nil def)))) - (concat - (format "\\footnote{%s}" (org-trim (org-export-data def info))) - ;; Retrieve all footnote references within the footnote and - ;; add their definition after it, since LaTeX doesn't support - ;; them inside. - (org-e-latex--delayed-footnotes-definitions def info))))))) - - -;;;; Headline - -(defun org-e-latex-headline (headline contents info) - "Transcode an HEADLINE element from Org to LaTeX. -CONTENTS holds the contents of the headline. INFO is a plist -holding contextual information." - (let* ((class (plist-get info :latex-class)) - (level (org-export-get-relative-level headline info)) - (numberedp (org-export-numbered-headline-p headline info)) - (class-sectionning (assoc class org-e-latex-classes)) - ;; Section formatting will set two placeholders: one for the - ;; title and the other for the contents. - (section-fmt - (let ((sec (if (and (symbolp (nth 2 class-sectionning)) - (fboundp (nth 2 class-sectionning))) - (funcall (nth 2 class-sectionning) level numberedp) - (nth (1+ level) class-sectionning)))) - (cond - ;; No section available for that LEVEL. - ((not sec) nil) - ;; Section format directly returned by a function. - ((stringp sec) sec) - ;; (numbered-section . unnumbered-section) - ((not (consp (cdr sec))) - (concat (funcall (if numberedp #'car #'cdr) sec) "\n%s")) - ;; (numbered-open numbered-close) - ((= (length sec) 2) - (when numberedp (concat (car sec) "\n%s" (nth 1 sec)))) - ;; (num-in num-out no-num-in no-num-out) - ((= (length sec) 4) - (if numberedp (concat (car sec) "\n%s" (nth 1 sec)) - (concat (nth 2 sec) "\n%s" (nth 3 sec))))))) - (text (org-export-data (org-element-property :title headline) info)) - (todo - (and (plist-get info :with-todo-keywords) - (let ((todo (org-element-property :todo-keyword headline))) - (and todo (org-export-data todo info))))) - (todo-type (and todo (org-element-property :todo-type headline))) - (tags (and (plist-get info :with-tags) - (org-export-get-tags headline info))) - (priority (and (plist-get info :with-priority) - (org-element-property :priority headline))) - ;; Create the headline text along with a no-tag version. The - ;; latter is required to remove tags from table of contents. - (full-text (if (functionp org-e-latex-format-headline-function) - ;; User-defined formatting function. - (funcall org-e-latex-format-headline-function - todo todo-type priority text tags) - ;; Default formatting. - (concat - (when todo - (format "\\textbf{\\textsf{\\textsc{%s}}} " todo)) - (when priority (format "\\framebox{\\#%c} " priority)) - text - (when tags - (format "\\hfill{}\\textsc{:%s:}" - (mapconcat 'identity tags ":")))))) - (full-text-no-tag - (if (functionp org-e-latex-format-headline-function) - ;; User-defined formatting function. - (funcall org-e-latex-format-headline-function - todo todo-type priority text nil) - ;; Default formatting. - (concat - (when todo (format "\\textbf{\\textsf{\\textsc{%s}}} " todo)) - (when priority (format "\\framebox{\\#%c} " priority)) - text))) - ;; Associate some \label to the headline for internal links. - (headline-label - (format "\\label{sec-%s}\n" - (mapconcat 'number-to-string - (org-export-get-headline-number headline info) - "-"))) - (pre-blanks - (make-string (org-element-property :pre-blank headline) 10))) - (cond - ;; Case 1: This is a footnote section: ignore it. - ((org-element-property :footnote-section-p headline) nil) - ;; Case 2. This is a deep sub-tree: export it as a list item. - ;; Also export as items headlines for which no section - ;; format has been found. - ((or (not section-fmt) (org-export-low-level-p headline info)) - ;; Build the real contents of the sub-tree. - (let ((low-level-body - (concat - ;; If the headline is the first sibling, start a list. - (when (org-export-first-sibling-p headline info) - (format "\\begin{%s}\n" (if numberedp 'enumerate 'itemize))) - ;; Itemize headline - "\\item " full-text "\n" headline-label pre-blanks contents))) - ;; If headline is not the last sibling simply return - ;; LOW-LEVEL-BODY. Otherwise, also close the list, before any - ;; blank line. - (if (not (org-export-last-sibling-p headline info)) low-level-body - (replace-regexp-in-string - "[ \t\n]*\\'" - (format "\n\\\\end{%s}" (if numberedp 'enumerate 'itemize)) - low-level-body)))) - ;; Case 3. Standard headline. Export it as a section. - (t - (cond - ((not (and tags (eq (plist-get info :with-tags) 'not-in-toc))) - ;; Regular section. Use specified format string. - (format section-fmt full-text - (concat headline-label pre-blanks contents))) - ((string-match "\\`\\\\\\(.*?\\){" section-fmt) - ;; If tags should be removed from table of contents, insert - ;; title without tags as an alternative heading in sectioning - ;; command. - (format (replace-match (concat (match-string 1 section-fmt) "[%s]") - nil nil section-fmt 1) - ;; Replace square brackets with parenthesis since - ;; square brackets are not supported in optional - ;; arguments. - (replace-regexp-in-string - "\\[" "(" - (replace-regexp-in-string - "\\]" ")" - full-text-no-tag)) - full-text - (concat headline-label pre-blanks contents))) - (t - ;; Impossible to add an alternative heading. Fallback to - ;; regular sectioning format string. - (format section-fmt full-text - (concat headline-label pre-blanks contents)))))))) - - -;;;; Horizontal Rule - -(defun org-e-latex-horizontal-rule (horizontal-rule contents info) - "Transcode an HORIZONTAL-RULE object from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - (let ((attr (org-export-read-attribute :attr_latex horizontal-rule)) - (prev (org-export-get-previous-element horizontal-rule info))) - (concat - ;; Make sure the rule doesn't start at the end of the current - ;; line by separating it with a blank line from previous element. - (when (and prev - (let ((prev-blank (org-element-property :post-blank prev))) - (or (not prev-blank) (zerop prev-blank)))) - "\n") - (org-e-latex--wrap-label - horizontal-rule - (format "\\rule{%s}{%s}" - (or (plist-get attr :width) "\\linewidth") - (or (plist-get attr :thickness) "0.5pt")))))) - - -;;;; Inline Babel Call -;; -;; Inline Babel Calls are ignored. - - -;;;; Inline Src Block - -(defun org-e-latex-inline-src-block (inline-src-block contents info) - "Transcode an INLINE-SRC-BLOCK element from Org to LaTeX. -CONTENTS holds the contents of the item. INFO is a plist holding -contextual information." - (let* ((code (org-element-property :value inline-src-block)) - (separator (org-e-latex--find-verb-separator code))) - (cond - ;; Do not use a special package: transcode it verbatim. - ((not org-e-latex-listings) - (concat "\\verb" separator code separator)) - ;; Use minted package. - ((eq org-e-latex-listings 'minted) - (let* ((org-lang (org-element-property :language inline-src-block)) - (mint-lang (or (cadr (assq (intern org-lang) - org-e-latex-minted-langs)) - org-lang)) - (options (org-e-latex--make-option-string - org-e-latex-minted-options))) - (concat (format "\\mint%s{%s}" - (if (string= options "") "" (format "[%s]" options)) - mint-lang) - separator code separator))) - ;; Use listings package. - (t - ;; Maybe translate language's name. - (let* ((org-lang (org-element-property :language inline-src-block)) - (lst-lang (or (cadr (assq (intern org-lang) - org-e-latex-listings-langs)) - org-lang)) - (options (org-e-latex--make-option-string - (append org-e-latex-listings-options - `(("language" ,lst-lang)))))) - (concat (format "\\lstinline[%s]" options) - separator code separator)))))) - - -;;;; Inlinetask - -(defun org-e-latex-inlinetask (inlinetask contents info) - "Transcode an INLINETASK element from Org to LaTeX. -CONTENTS holds the contents of the block. INFO is a plist -holding contextual information." - (let ((title (org-export-data (org-element-property :title inlinetask) info)) - (todo (and (plist-get info :with-todo-keywords) - (let ((todo (org-element-property :todo-keyword inlinetask))) - (and todo (org-export-data todo info))))) - (todo-type (org-element-property :todo-type inlinetask)) - (tags (and (plist-get info :with-tags) - (org-export-get-tags inlinetask info))) - (priority (and (plist-get info :with-priority) - (org-element-property :priority inlinetask)))) - ;; If `org-e-latex-format-inlinetask-function' is provided, call it - ;; with appropriate arguments. - (if (functionp org-e-latex-format-inlinetask-function) - (funcall org-e-latex-format-inlinetask-function - todo todo-type priority title tags contents) - ;; Otherwise, use a default template. - (org-e-latex--wrap-label - inlinetask - (let ((full-title - (concat - (when todo (format "\\textbf{\\textsf{\\textsc{%s}}} " todo)) - (when priority (format "\\framebox{\\#%c} " priority)) - title - (when tags (format "\\hfill{}\\textsc{:%s:}" - (mapconcat 'identity tags ":")))))) - (format (concat "\\begin{center}\n" - "\\fbox{\n" - "\\begin{minipage}[c]{.6\\textwidth}\n" - "%s\n\n" - "\\rule[.8em]{\\textwidth}{2pt}\n\n" - "%s" - "\\end{minipage}\n" - "}\n" - "\\end{center}") - full-title contents)))))) - - -;;;; Italic - -(defun org-e-latex-italic (italic contents info) - "Transcode ITALIC from Org to LaTeX. -CONTENTS is the text with italic markup. INFO is a plist holding -contextual information." - (org-e-latex--text-markup contents 'italic)) - - -;;;; Item - -(defun org-e-latex-item (item contents info) - "Transcode an ITEM element from Org to LaTeX. -CONTENTS holds the contents of the item. INFO is a plist holding -contextual information." - (let* ((counter - (let ((count (org-element-property :counter item)) - (level - (loop for parent in (org-export-get-genealogy item) - count (eq (org-element-type parent) 'plain-list) - until (eq (org-element-type parent) 'headline)))) - (and count - (< level 5) - (format "\\setcounter{enum%s}{%s}\n" - (nth (1- level) '("i" "ii" "iii" "iv")) - (1- count))))) - (checkbox (case (org-element-property :checkbox item) - (on "$\\boxtimes$ ") - (off "$\\Box$ ") - (trans "$\\boxminus$ "))) - (tag (let ((tag (org-element-property :tag item))) - ;; Check-boxes must belong to the tag. - (and tag (format "[%s] " - (concat checkbox - (org-export-data tag info))))))) - (concat counter "\\item" (or tag (concat " " checkbox)) - (and contents (org-trim contents)) - ;; If there are footnotes references in tag, be sure to - ;; add their definition at the end of the item. This - ;; workaround is necessary since "\footnote{}" command is - ;; not supported in tags. - (and tag - (org-e-latex--delayed-footnotes-definitions - (org-element-property :tag item) info))))) - - -;;;; Keyword - -(defun org-e-latex-keyword (keyword contents info) - "Transcode a KEYWORD element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - (let ((key (org-element-property :key keyword)) - (value (org-element-property :value keyword))) - (cond - ((string= key "LATEX") value) - ((string= key "INDEX") (format "\\index{%s}" value)) - ;; Invisible targets. - ((string= key "TARGET") nil) - ((string= key "TOC") - (let ((value (downcase value))) - (cond - ((string-match "\\<headlines\\>" value) - (let ((depth (or (and (string-match "[0-9]+" value) - (string-to-number (match-string 0 value))) - (plist-get info :with-toc)))) - (concat - (when (wholenump depth) - (format "\\setcounter{tocdepth}{%s}\n" depth)) - "\\tableofcontents"))) - ((string= "tables" value) "\\listoftables") - ((string= "figures" value) "\\listoffigures") - ((string= "listings" value) - (cond - ((eq org-e-latex-listings 'minted) "\\listoflistings") - (org-e-latex-listings "\\lstlistoflistings") - ;; At the moment, src blocks with a caption are wrapped - ;; into a figure environment. - (t "\\listoffigures"))))))))) - - -;;;; Latex Environment - -(defun org-e-latex-latex-environment (latex-environment contents info) - "Transcode a LATEX-ENVIRONMENT element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - (let ((label (org-element-property :name latex-environment)) - (value (org-remove-indentation - (org-element-property :value latex-environment)))) - (if (not (org-string-nw-p label)) value - ;; Environment is labelled: label must be within the environment - ;; (otherwise, a reference pointing to that element will count - ;; the section instead). - (with-temp-buffer - (insert value) - (goto-char (point-min)) - (forward-line) - (insert (format "\\label{%s}\n" label)) - (buffer-string))))) - - -;;;; Latex Fragment - -(defun org-e-latex-latex-fragment (latex-fragment contents info) - "Transcode a LATEX-FRAGMENT object from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - (org-element-property :value latex-fragment)) - - -;;;; Line Break - -(defun org-e-latex-line-break (line-break contents info) - "Transcode a LINE-BREAK object from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - "\\\\") - - -;;;; Link - -(defun org-e-latex-link--inline-image (link info) - "Return LaTeX code for an inline image. -LINK is the link pointing to the inline image. INFO is a plist -used as a communication channel." - (let* ((parent (org-export-get-parent-element link)) - (path (let ((raw-path (org-element-property :path link))) - (if (not (file-name-absolute-p raw-path)) raw-path - (expand-file-name raw-path)))) - (caption (org-e-latex--caption/label-string - (org-element-property :caption parent) - (org-element-property :name parent) - info)) - ;; Retrieve latex attributes from the element around. - (attr (let ((raw-attr - (mapconcat #'identity - (org-element-property :attr_latex parent) - " "))) - (unless (string= raw-attr "") raw-attr))) - (disposition - (cond - ((and attr (string-match "\\<wrap\\>" attr)) 'wrap) - ((and attr (string-match "\\<multicolumn\\>" attr)) 'multicolumn) - ((or (and attr (string-match "\\<float\\>" attr)) - (not (string= caption ""))) - 'float))) - (placement - (cond - ((and attr (string-match "\\<placement=\\(\\S-+\\)" attr)) - (org-match-string-no-properties 1 attr)) - ((eq disposition 'wrap) "{l}{0.5\\textwidth}") - ((eq disposition 'float) - (concat "[" org-e-latex-default-figure-position "]")) - (t "")))) - ;; Now clear ATTR from any special keyword and set a default - ;; value if nothing is left. - (setq attr - (if (not attr) "" - (org-trim - (replace-regexp-in-string - "\\(wrap\\|multicolumn\\|float\\|placement=\\S-+\\)" "" attr)))) - (setq attr (cond ((not (string= attr "")) attr) - ((eq disposition 'float) "width=0.7\\textwidth") - ((eq disposition 'wrap) "width=0.48\\textwidth") - (t (or org-e-latex-image-default-option "")))) - ;; Return proper string, depending on DISPOSITION. - (case disposition - (wrap (format "\\begin{wrapfigure}%s -\\centering -\\includegraphics[%s]{%s} -%s\\end{wrapfigure}" placement attr path caption)) - (multicolumn (format "\\begin{figure*}%s -\\centering -\\includegraphics[%s]{%s} -%s\\end{figure*}" placement attr path caption)) - (float (format "\\begin{figure}%s -\\centering -\\includegraphics[%s]{%s} -%s\\end{figure}" placement attr path caption)) - (t (format "\\includegraphics[%s]{%s}" attr path))))) - -(defun org-e-latex-link (link desc info) - "Transcode a LINK object from Org to LaTeX. - -DESC is the description part of the link, or the empty string. -INFO is a plist holding contextual information. See -`org-export-data'." - (let* ((type (org-element-property :type link)) - (raw-path (org-element-property :path link)) - ;; Ensure DESC really exists, or set it to nil. - (desc (and (not (string= desc "")) desc)) - (imagep (org-export-inline-image-p - link org-e-latex-inline-image-rules)) - (path (cond - ((member type '("http" "https" "ftp" "mailto")) - (concat type ":" raw-path)) - ((string= type "file") - (when (string-match "\\(.+\\)::.+" raw-path) - (setq raw-path (match-string 1 raw-path))) - (if (file-name-absolute-p raw-path) - (concat "file://" (expand-file-name raw-path)) - (concat "file://" raw-path))) - (t raw-path))) - protocol) - (cond - ;; Image file. - (imagep (org-e-latex-link--inline-image link info)) - ;; Radio link: Transcode target's contents and use them as link's - ;; description. - ((string= type "radio") - (let ((destination (org-export-resolve-radio-link link info))) - (when destination - (format "\\hyperref[%s]{%s}" - (org-export-solidify-link-text path) - (org-export-data (org-element-contents destination) info))))) - ;; Links pointing to an headline: Find destination and build - ;; appropriate referencing command. - ((member type '("custom-id" "fuzzy" "id")) - (let ((destination (if (string= type "fuzzy") - (org-export-resolve-fuzzy-link link info) - (org-export-resolve-id-link link info)))) - (case (org-element-type destination) - ;; Id link points to an external file. - (plain-text - (if desc (format "\\href{file://%s}{%s}" destination desc) - (format "\\url{file://%s}" destination))) - ;; Fuzzy link points nowhere. - ('nil - (format org-e-latex-link-with-unknown-path-format - (or desc - (org-export-data - (org-element-property :raw-link link) info)))) - ;; Fuzzy link points to an invisible target. - (keyword nil) - ;; LINK points to an headline. If headlines are numbered - ;; and the link has no description, display headline's - ;; number. Otherwise, display description or headline's - ;; title. - (headline - (let ((label - (format "sec-%s" - (mapconcat - 'number-to-string - (org-export-get-headline-number destination info) - "-")))) - (if (and (plist-get info :section-numbers) (not desc)) - (format "\\ref{%s}" label) - (format "\\hyperref[%s]{%s}" label - (or desc - (org-export-data - (org-element-property :title destination) info)))))) - ;; Fuzzy link points to a target. Do as above. - (otherwise - (let ((path (org-export-solidify-link-text path))) - (if (not desc) (format "\\ref{%s}" path) - (format "\\hyperref[%s]{%s}" path desc))))))) - ;; Coderef: replace link with the reference name or the - ;; equivalent line number. - ((string= type "coderef") - (format (org-export-get-coderef-format path desc) - (org-export-resolve-coderef path info))) - ;; Link type is handled by a special function. - ((functionp (setq protocol (nth 2 (assoc type org-link-protocols)))) - (funcall protocol (org-link-unescape path) desc 'latex)) - ;; External link with a description part. - ((and path desc) (format "\\href{%s}{%s}" path desc)) - ;; External link without a description part. - (path (format "\\url{%s}" path)) - ;; No path, only description. Try to do something useful. - (t (format org-e-latex-link-with-unknown-path-format desc))))) - - -;;;; Macro - -(defun org-e-latex-macro (macro contents info) - "Transcode a MACRO element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - ;; Use available tools. - (org-export-expand-macro macro info)) - - -;;;; Paragraph - -(defun org-e-latex-paragraph (paragraph contents info) - "Transcode a PARAGRAPH element from Org to LaTeX. -CONTENTS is the contents of the paragraph, as a string. INFO is -the plist used as a communication channel." - contents) - - -;;;; Plain List - -(defun org-e-latex-plain-list (plain-list contents info) - "Transcode a PLAIN-LIST element from Org to LaTeX. -CONTENTS is the contents of the list. INFO is a plist holding -contextual information." - (let* ((type (org-element-property :type plain-list)) - (paralist-types '("inparaenum" "asparaenum" "inparaitem" "asparaitem" - "inparadesc" "asparadesc")) - (paralist-regexp (concat - "\\(" - (mapconcat 'identity paralist-types "\\|") - "\\)")) - (attr (mapconcat #'identity - (org-element-property :attr_latex plain-list) - " ")) - (latex-type (cond - ((and attr - (string-match - (format "\\<%s\\>" paralist-regexp) attr)) - (match-string 1 attr)) - ((eq type 'ordered) "enumerate") - ((eq type 'unordered) "itemize") - ((eq type 'descriptive) "description")))) - (org-e-latex--wrap-label - plain-list - (format "\\begin{%s}%s\n%s\\end{%s}" - latex-type - ;; Once special environment, if any, has been removed, the - ;; rest of the attributes will be optional arguments. - ;; They will be put inside square brackets if necessary. - (let ((opt (replace-regexp-in-string - (format " *%s *" paralist-regexp) "" attr))) - (cond ((string= opt "") "") - ((string-match "\\`\\[[^][]+\\]\\'" opt) opt) - (t (format "[%s]" opt)))) - contents - latex-type)))) - - -;;;; Plain Text - -(defun org-e-latex-plain-text (text info) - "Transcode a TEXT string from Org to LaTeX. -TEXT is the string to transcode. INFO is a plist holding -contextual information." - ;; Protect %, #, &, $, ~, ^, _, { and }. - (while (string-match "\\([^\\]\\|^\\)\\([%$#&{}~^_]\\)" text) - (setq text - (replace-match (format "\\%s" (match-string 2 text)) nil t text 2))) - ;; Protect \ - (setq text (replace-regexp-in-string - "\\(?:[^\\]\\|^\\)\\(\\\\\\)\\(?:[^%$#&{}~^_\\]\\|$\\)" - "$\\backslash$" text nil t 1)) - ;; LaTeX into \LaTeX{} and TeX into \TeX{}. - (let ((case-fold-search nil) - (start 0)) - (while (string-match "\\<\\(\\(?:La\\)?TeX\\)\\>" text start) - (setq text (replace-match - (format "\\%s{}" (match-string 1 text)) nil t text) - start (match-end 0)))) - ;; Handle quotation marks - (setq text (org-e-latex--quotation-marks text info)) - ;; Convert special strings. - (when (plist-get info :with-special-strings) - (while (string-match (regexp-quote "...") text) - (setq text (replace-match "\\ldots{}" nil t text)))) - ;; Handle break preservation if required. - (when (plist-get info :preserve-breaks) - (setq text (replace-regexp-in-string "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" - text))) - ;; Return value. - text) - - -;;;; Planning - -(defun org-e-latex-planning (planning contents info) - "Transcode a PLANNING element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual -information." - (concat - "\\noindent" - (mapconcat - 'identity - (delq nil - (list - (let ((closed (org-element-property :closed planning))) - (when closed - (concat - (format "\\textbf{%s} " org-closed-string) - (format org-e-latex-inactive-timestamp-format - (org-translate-time closed))))) - (let ((deadline (org-element-property :deadline planning))) - (when deadline - (concat - (format "\\textbf{%s} " org-deadline-string) - (format org-e-latex-active-timestamp-format - (org-translate-time deadline))))) - (let ((scheduled (org-element-property :scheduled planning))) - (when scheduled - (concat - (format "\\textbf{%s} " org-scheduled-string) - (format org-e-latex-active-timestamp-format - (org-translate-time scheduled))))))) - " ") - "\\\\")) - - -;;;; Property Drawer - -(defun org-e-latex-property-drawer (property-drawer contents info) - "Transcode a PROPERTY-DRAWER element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual -information." - ;; The property drawer isn't exported but we want separating blank - ;; lines nonetheless. - "") - - -;;;; Quote Block - -(defun org-e-latex-quote-block (quote-block contents info) - "Transcode a QUOTE-BLOCK element from Org to LaTeX. -CONTENTS holds the contents of the block. INFO is a plist -holding contextual information." - (org-e-latex--wrap-label - quote-block - (format "\\begin{quote}\n%s\\end{quote}" contents))) - - -;;;; Quote Section - -(defun org-e-latex-quote-section (quote-section contents info) - "Transcode a QUOTE-SECTION element from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - (let ((value (org-remove-indentation - (org-element-property :value quote-section)))) - (when value (format "\\begin{verbatim}\n%s\\end{verbatim}" value)))) - - -;;;; Radio Target - -(defun org-e-latex-radio-target (radio-target text info) - "Transcode a RADIO-TARGET object from Org to LaTeX. -TEXT is the text of the target. INFO is a plist holding -contextual information." - (format "\\label{%s}%s" - (org-export-solidify-link-text - (org-element-property :value radio-target)) - text)) - - -;;;; Section - -(defun org-e-latex-section (section contents info) - "Transcode a SECTION element from Org to LaTeX. -CONTENTS holds the contents of the section. INFO is a plist -holding contextual information." - contents) - - -;;;; Special Block - -(defun org-e-latex-special-block (special-block contents info) - "Transcode a SPECIAL-BLOCK element from Org to LaTeX. -CONTENTS holds the contents of the block. INFO is a plist -holding contextual information." - (let ((type (downcase (org-element-property :type special-block)))) - (org-e-latex--wrap-label - special-block - (format "\\begin{%s}\n%s\\end{%s}" type contents type)))) - - -;;;; Src Block - -(defun org-e-latex-src-block (src-block contents info) - "Transcode a SRC-BLOCK element from Org to LaTeX. -CONTENTS holds the contents of the item. INFO is a plist holding -contextual information." - (let* ((lang (org-element-property :language src-block)) - (caption (org-element-property :caption src-block)) - (label (org-element-property :name src-block)) - (custom-env (and lang - (cadr (assq (intern lang) - org-e-latex-custom-lang-environments)))) - (num-start (case (org-element-property :number-lines src-block) - (continued (org-export-get-loc src-block info)) - (new 0))) - (retain-labels (org-element-property :retain-labels src-block))) - (cond - ;; Case 1. No source fontification. - ((not org-e-latex-listings) - (let ((caption-str (org-e-latex--caption/label-string caption label info)) - (float-env (when caption "\\begin{figure}[H]\n%s\n\\end{figure}"))) - (format - (or float-env "%s") - (concat caption-str - (format "\\begin{verbatim}\n%s\\end{verbatim}" - (org-export-format-code-default src-block info)))))) - ;; Case 2. Custom environment. - (custom-env (format "\\begin{%s}\n%s\\end{%s}\n" - custom-env - (org-export-format-code-default src-block info) - custom-env)) - ;; Case 3. Use minted package. - ((eq org-e-latex-listings 'minted) - (let ((float-env (when (or label caption) - (format "\\begin{listing}[H]\n%%s\n%s\\end{listing}" - (org-e-latex--caption/label-string - caption label info)))) - (body - (format - "\\begin{minted}[%s]{%s}\n%s\\end{minted}" - ;; Options. - (org-e-latex--make-option-string - (if (not num-start) org-e-latex-minted-options - (append `(("linenos") - ("firstnumber" ,(number-to-string (1+ num-start)))) - org-e-latex-minted-options))) - ;; Language. - (or (cadr (assq (intern lang) org-e-latex-minted-langs)) lang) - ;; Source code. - (let* ((code-info (org-export-unravel-code src-block)) - (max-width - (apply 'max - (mapcar 'length - (org-split-string (car code-info) "\n"))))) - (org-export-format-code - (car code-info) - (lambda (loc num ref) - (concat - loc - (when ref - ;; Ensure references are flushed to the right, - ;; separated with 6 spaces from the widest line - ;; of code. - (concat (make-string (+ (- max-width (length loc)) 6) ? ) - (format "(%s)" ref))))) - nil (and retain-labels (cdr code-info))))))) - ;; Return value. - (if float-env (format float-env body) body))) - ;; Case 4. Use listings package. - (t - (let ((lst-lang - (or (cadr (assq (intern lang) org-e-latex-listings-langs)) lang)) - (caption-str - (when caption - (let ((main (org-export-data (car caption) info))) - (if (not (cdr caption)) (format "{%s}" main) - (format "{[%s]%s}" - (org-export-data (cdr caption) info) - main)))))) - (concat - ;; Options. - (format "\\lstset{%s}\n" - (org-e-latex--make-option-string - (append org-e-latex-listings-options - `(("language" ,lst-lang)) - (when label `(("label" ,label))) - (when caption-str `(("caption" ,caption-str))) - (cond ((not num-start) '(("numbers" "none"))) - ((zerop num-start) '(("numbers" "left"))) - (t `(("numbers" "left") - ("firstnumber" - ,(number-to-string (1+ num-start))))))))) - ;; Source code. - (format - "\\begin{lstlisting}\n%s\\end{lstlisting}" - (let* ((code-info (org-export-unravel-code src-block)) - (max-width - (apply 'max - (mapcar 'length - (org-split-string (car code-info) "\n"))))) - (org-export-format-code - (car code-info) - (lambda (loc num ref) - (concat - loc - (when ref - ;; Ensure references are flushed to the right, - ;; separated with 6 spaces from the widest line of - ;; code - (concat (make-string (+ (- max-width (length loc)) 6) ? ) - (format "(%s)" ref))))) - nil (and retain-labels (cdr code-info))))))))))) - - -;;;; Statistics Cookie - -(defun org-e-latex-statistics-cookie (statistics-cookie contents info) - "Transcode a STATISTICS-COOKIE object from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual information." - (replace-regexp-in-string - "%" "\\%" (org-element-property :value statistics-cookie) nil t)) - - -;;;; Strike-Through - -(defun org-e-latex-strike-through (strike-through contents info) - "Transcode STRIKE-THROUGH from Org to LaTeX. -CONTENTS is the text with strike-through markup. INFO is a plist -holding contextual information." - (org-e-latex--text-markup contents 'strike-through)) - - -;;;; Subscript - -(defun org-e-latex-subscript (subscript contents info) - "Transcode a SUBSCRIPT object from Org to LaTeX. -CONTENTS is the contents of the object. INFO is a plist holding -contextual information." - (if (= (length contents) 1) (format "$_%s$" contents) - ;; Handle multiple objects in SUBSCRIPT by creating a subscript - ;; command for each of them. - (let ((prev-blanks 0)) - (mapconcat - (lambda (obj) - (case (org-element-type obj) - ((entity latex-fragment) - (setq prev-blanks (org-element-property :post-blank obj)) - (let ((data (org-trim (org-export-data obj info)))) - (string-match - "\\`\\(?:\\\\[([]\\|\\$+\\)?\\(.*?\\)\\(?:\\\\[])]\\|\\$+\\)?\\'" - data) - (format "$_{%s}$" (match-string 1 data)))) - (plain-text - (format "$_\\mathrm{%s}$" - (concat (make-string prev-blanks ? ) - ;; mathrm command doesn't handle spaces, - ;; so we have to enforce them. - (replace-regexp-in-string - " " "\\\\ " (org-export-data obj info))))) - (otherwise - (setq prev-blanks (org-element-property :post-blank obj)) - (format "$_{%s}$" (org-export-data obj info))))) - (org-element-contents subscript) "")))) - - -;;;; Superscript - -(defun org-e-latex-superscript (superscript contents info) - "Transcode a SUPERSCRIPT object from Org to LaTeX. -CONTENTS is the contents of the object. INFO is a plist holding -contextual information." - (if (= (length contents) 1) (format "$^%s$" contents) - ;; Handle multiple objects in SUPERSCRIPT by creating - ;; a superscript command for each of them. - (let ((prev-blanks 0)) - (mapconcat - (lambda (obj) - (case (org-element-type obj) - ((entity latex-fragment) - (setq prev-blanks (org-element-property :post-blank obj)) - (let ((data (org-trim (org-export-data obj info)))) - (string-match - "\\`\\(?:\\\\[([]\\|\\$+\\)?\\(.*?\\)\\(?:\\\\[])]\\|\\$+\\)?\\'" - data) - (format "$^{%s}$" (match-string 1 data)))) - (plain-text - (format "$^\\mathrm{%s}$" - (concat (make-string prev-blanks ? ) - ;; mathrm command doesn't handle spaces, - ;; so we have to enforce them. - (replace-regexp-in-string - " " "\\\\ " (org-export-data obj info))))) - (otherwise - (setq prev-blanks (org-element-property :post-blank obj)) - (format "$^{%s}$" (org-export-data obj info))))) - (org-element-contents superscript) "")))) - - -;;;; Table -;; -;; `org-e-latex-table' is the entry point for table transcoding. It -;; takes care of tables with a "verbatim" attribute. Otherwise, it -;; delegates the job to either `org-e-latex-table--table.el-table' or -;; `org-e-latex-table--org-table' functions, depending of the type of -;; the table. -;; -;; `org-e-latex-table--align-string' is a subroutine used to build -;; alignment string for Org tables. - -(defun org-e-latex-table (table contents info) - "Transcode a TABLE element from Org to LaTeX. -CONTENTS is the contents of the table. INFO is a plist holding -contextual information." - (cond - ;; Case 1: verbatim table. - ((or org-e-latex-tables-verbatim - (let ((attr (mapconcat 'identity - (org-element-property :attr_latex table) - " "))) - (and attr (string-match "\\<verbatim\\>" attr)))) - (format "\\begin{verbatim}\n%s\n\\end{verbatim}" - ;; Re-create table, without affiliated keywords. - (org-trim - (org-element-interpret-data - `(table nil ,@(org-element-contents table)))))) - ;; Case 2: table.el table. Convert it using appropriate tools. - ((eq (org-element-property :type table) 'table.el) - (org-e-latex-table--table.el-table table contents info)) - ;; Case 3: Standard table. - (t (org-e-latex-table--org-table table contents info)))) - -(defun org-e-latex-table--align-string (table info) - "Return an appropriate LaTeX alignment string. -TABLE is the considered table. INFO is a plist used as -a communication channel." - (let ((attr (mapconcat 'identity - (org-element-property :attr_latex table) - " "))) - (if (string-match "\\<align=\\(\\S-+\\)" attr) (match-string 1 attr) - (let (alignment) - ;; Extract column groups and alignment from first (non-rule) - ;; row. - (org-element-map - (org-element-map - table 'table-row - (lambda (row) - (and (eq (org-element-property :type row) 'standard) row)) - info 'first-match) - 'table-cell - (lambda (cell) - (let ((borders (org-export-table-cell-borders cell info))) - ;; Check left border for the first cell only. - (when (and (memq 'left borders) (not alignment)) - (push "|" alignment)) - (push (case (org-export-table-cell-alignment cell info) - (left "l") - (right "r") - (center "c")) - alignment) - (when (memq 'right borders) (push "|" alignment)))) - info) - (apply 'concat (reverse alignment)))))) - -(defun org-e-latex-table--org-table (table contents info) - "Return appropriate LaTeX code for an Org table. - -TABLE is the table type element to transcode. CONTENTS is its -contents, as a string. INFO is a plist used as a communication -channel. - -This function assumes TABLE has `org' as its `:type' attribute." - (let* ((label (org-element-property :name table)) - (caption (org-e-latex--caption/label-string - (org-element-property :caption table) label info)) - (attr (mapconcat 'identity - (org-element-property :attr_latex table) - " ")) - ;; Determine alignment string. - (alignment (org-e-latex-table--align-string table info)) - ;; Determine environment for the table: longtable, tabular... - (table-env (cond - ((not attr) org-e-latex-default-table-environment) - ((string-match "\\<longtable\\>" attr) "longtable") - ((string-match "\\<tabular.?\\>" attr) - (org-match-string-no-properties 0 attr)) - (t org-e-latex-default-table-environment))) - ;; If table is a float, determine environment: table, table* - ;; or sidewaystable. - (float-env (cond - ((string= "longtable" table-env) nil) - ((and attr (string-match "\\<sidewaystable\\>" attr)) - "sidewaystable") - ((and attr - (or (string-match (regexp-quote "table*") attr) - (string-match "\\<multicolumn\\>" attr))) - "table*") - ((or (not (string= caption "")) label) "table"))) - ;; Extract others display options. - (width (and attr (string-match "\\<width=\\(\\S-+\\)" attr) - (org-match-string-no-properties 1 attr))) - (placement - (if (and attr (string-match "\\<placement=\\(\\S-+\\)" attr)) - (org-match-string-no-properties 1 attr) - (format "[%s]" org-e-latex-default-figure-position)))) - ;; Prepare the final format string for the table. - (cond - ;; Longtable. - ((string= "longtable" table-env) - (format - "\\begin{longtable}{%s}\n%s%s%s\\end{longtable}" - alignment - (if (or (not org-e-latex-table-caption-above) (string= "" caption)) "" - (concat (org-trim caption) "\\\\\n")) - contents - (if (or org-e-latex-table-caption-above (string= "" caption)) "" - (concat (org-trim caption) "\\\\\n")))) - ;; Others. - (t (concat (when float-env - (concat - (format "\\begin{%s}%s\n" float-env placement) - (if org-e-latex-table-caption-above caption ""))) - (when org-e-latex-tables-centered "\\begin{center}\n") - (format "\\begin{%s}%s{%s}\n%s\\end{%s}" - table-env - (if width (format "{%s}" width) "") - alignment - contents - table-env) - (when org-e-latex-tables-centered "\n\\end{center}") - (when float-env - (concat (if org-e-latex-table-caption-above "" caption) - (format "\n\\end{%s}" float-env)))))))) - -(defun org-e-latex-table--table.el-table (table contents info) - "Return appropriate LaTeX code for a table.el table. - -TABLE is the table type element to transcode. CONTENTS is its -contents, as a string. INFO is a plist used as a communication -channel. - -This function assumes TABLE has `table.el' as its `:type' -attribute." - (require 'table) - ;; Ensure "*org-export-table*" buffer is empty. - (with-current-buffer (get-buffer-create "*org-export-table*") - (erase-buffer)) - (let ((output (with-temp-buffer - (insert (org-element-property :value table)) - (goto-char 1) - (re-search-forward "^[ \t]*|[^|]" nil t) - (table-generate-source 'latex "*org-export-table*") - (with-current-buffer "*org-export-table*" - (org-trim (buffer-string)))))) - (kill-buffer (get-buffer "*org-export-table*")) - ;; Remove left out comments. - (while (string-match "^%.*\n" output) - (setq output (replace-match "" t t output))) - ;; When the "rmlines" attribute is provided, remove all hlines but - ;; the the one separating heading from the table body. - (let ((attr (mapconcat 'identity - (org-element-property :attr_latex table) - " "))) - (when (and attr (string-match "\\<rmlines\\>" attr)) - (let ((n 0) (pos 0)) - (while (and (< (length output) pos) - (setq pos (string-match "^\\\\hline\n?" output pos))) - (incf n) - (unless (= n 2) - (setq output (replace-match "" nil nil output))))))) - (if (not org-e-latex-tables-centered) output - (format "\\begin{center}\n%s\n\\end{center}" output)))) - - -;;;; Table Cell - -(defun org-e-latex-table-cell (table-cell contents info) - "Transcode a TABLE-CELL element from Org to LaTeX. -CONTENTS is the cell contents. INFO is a plist used as -a communication channel." - (concat (if (and contents - org-e-latex-table-scientific-notation - (string-match orgtbl-exp-regexp contents)) - ;; Use appropriate format string for scientific - ;; notation. - (format org-e-latex-table-scientific-notation - (match-string 1 contents) - (match-string 2 contents)) - contents) - (when (org-export-get-next-element table-cell info) " & "))) - - -;;;; Table Row - -(defun org-e-latex-table-row (table-row contents info) - "Transcode a TABLE-ROW element from Org to LaTeX. -CONTENTS is the contents of the row. INFO is a plist used as -a communication channel." - ;; Rules are ignored since table separators are deduced from - ;; borders of the current row. - (when (eq (org-element-property :type table-row) 'standard) - (let* ((attr (mapconcat 'identity - (org-element-property - :attr_latex (org-export-get-parent table-row)) - " ")) - (longtablep (and attr (string-match "\\<longtable\\>" attr))) - (booktabsp - (or (and attr (string-match "\\<booktabs=\\(yes\\|t\\)\\>" attr)) - org-e-latex-tables-booktabs)) - ;; TABLE-ROW's borders are extracted from its first cell. - (borders - (org-export-table-cell-borders - (car (org-element-contents table-row)) info))) - (concat - ;; When BOOKTABS are activated enforce top-rule even when no - ;; hline was specifically marked. - (cond ((and booktabsp (memq 'top borders)) "\\toprule\n") - ((and (memq 'top borders) (memq 'above borders)) "\\hline\n")) - contents "\\\\\n" - (cond - ;; Special case for long tables. Define header and footers. - ((and longtablep (org-export-table-row-ends-header-p table-row info)) - (format "%s -\\endhead -%s\\multicolumn{%d}{r}{Continued on next page} \\\\ -\\endfoot -\\endlastfoot" - (if booktabsp "\\midrule" "\\hline") - (if booktabsp "\\midrule" "\\hline") - ;; Number of columns. - (cdr (org-export-table-dimensions - (org-export-get-parent-table table-row) info)))) - ;; When BOOKTABS are activated enforce bottom rule even when - ;; no hline was specifically marked. - ((and booktabsp (memq 'bottom borders)) "\\bottomrule") - ((and (memq 'bottom borders) (memq 'below borders)) "\\hline") - ((memq 'below borders) (if booktabsp "\\midrule" "\\hline"))))))) - - -;;;; Target - -(defun org-e-latex-target (target contents info) - "Transcode a TARGET object from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual -information." - (format "\\label{%s}" - (org-export-solidify-link-text (org-element-property :value target)))) - - -;;;; Timestamp - -(defun org-e-latex-timestamp (timestamp contents info) - "Transcode a TIMESTAMP object from Org to LaTeX. -CONTENTS is nil. INFO is a plist holding contextual -information." - (let ((value (org-translate-time (org-element-property :value timestamp))) - (range-end (org-element-property :range-end timestamp))) - (case (org-element-property :type timestamp) - (active (format org-e-latex-active-timestamp-format value)) - (active-range - (concat (format org-e-latex-active-timestamp-format value) - "--" - (format org-e-latex-active-timestamp-format - (org-translate-time range-end)))) - (inactive (format org-e-latex-inactive-timestamp-format value)) - (inactive-range - (concat (format org-e-latex-inactive-timestamp-format value) - "--" - (format org-e-latex-inactive-timestamp-format - (org-translate-time range-end)))) - (otherwise (format org-e-latex-diary-timestamp-format value))))) - - -;;;; Underline - -(defun org-e-latex-underline (underline contents info) - "Transcode UNDERLINE from Org to LaTeX. -CONTENTS is the text with underline markup. INFO is a plist -holding contextual information." - (org-e-latex--text-markup contents 'underline)) - - -;;;; Verbatim - -(defun org-e-latex-verbatim (verbatim contents info) - "Transcode a VERBATIM object from Org to LaTeX. -CONTENTS is nil. INFO is a plist used as a communication -channel." - (org-e-latex--text-markup (org-element-property :value verbatim) 'verbatim)) - - -;;;; Verse Block - -(defun org-e-latex-verse-block (verse-block contents info) - "Transcode a VERSE-BLOCK element from Org to LaTeX. -CONTENTS is verse block contents. INFO is a plist holding -contextual information." - (org-e-latex--wrap-label - verse-block - ;; In a verse environment, add a line break to each newline - ;; character and change each white space at beginning of a line - ;; into a space of 1 em. Also change each blank line with - ;; a vertical space of 1 em. - (progn - (setq contents (replace-regexp-in-string - "^ *\\\\\\\\$" "\\\\vspace*{1em}" - (replace-regexp-in-string - "\\(\\\\\\\\\\)?[ \t]*\n" " \\\\\\\\\n" contents))) - (while (string-match "^[ \t]+" contents) - (let ((new-str (format "\\hspace*{%dem}" - (length (match-string 0 contents))))) - (setq contents (replace-match new-str nil t contents)))) - (format "\\begin{verse}\n%s\\end{verse}" contents)))) - - - -;;; Interactive functions - -;;;###autoload -(defun org-e-latex-export-as-latex - (&optional subtreep visible-only body-only ext-plist) - "Export current buffer as a LaTeX buffer. - -If narrowing is active in the current buffer, only export its -narrowed part. - -If a region is active, export that region. - -When optional argument SUBTREEP is non-nil, export the sub-tree -at point, extracting information from the headline properties -first. - -When optional argument VISIBLE-ONLY is non-nil, don't export -contents of hidden elements. - -When optional argument BODY-ONLY is non-nil, only write code -between \"\\begin{document}\" and \"\\end{document}\". - -EXT-PLIST, when provided, is a property list with external -parameters overriding Org default settings, but still inferior to -file-local settings. - -Export is done in a buffer named \"*Org E-LATEX Export*\", which -will be displayed when `org-export-show-temporary-export-buffer' -is non-nil." - (interactive) - (let ((outbuf (org-export-to-buffer - 'e-latex "*Org E-LATEX Export*" - subtreep visible-only body-only ext-plist))) - (with-current-buffer outbuf (LaTeX-mode)) - (when org-export-show-temporary-export-buffer - (switch-to-buffer-other-window outbuf)))) - -;;;###autoload -(defun org-e-latex-export-to-latex - (&optional subtreep visible-only body-only ext-plist pub-dir) - "Export current buffer to a LaTeX file. - -If narrowing is active in the current buffer, only export its -narrowed part. - -If a region is active, export that region. - -When optional argument SUBTREEP is non-nil, export the sub-tree -at point, extracting information from the headline properties -first. - -When optional argument VISIBLE-ONLY is non-nil, don't export -contents of hidden elements. - -When optional argument BODY-ONLY is non-nil, only write code -between \"\\begin{document}\" and \"\\end{document}\". - -EXT-PLIST, when provided, is a property list with external -parameters overriding Org default settings, but still inferior to -file-local settings. - -When optional argument PUB-DIR is set, use it as the publishing -directory. - -Return output file's name." - (interactive) - (let ((outfile (org-export-output-file-name ".tex" subtreep pub-dir))) - (org-export-to-file - 'e-latex outfile subtreep visible-only body-only ext-plist))) - -;;;###autoload -(defun org-e-latex-export-to-pdf - (&optional subtreep visible-only body-only ext-plist pub-dir) - "Export current buffer to LaTeX then process through to PDF. - -If narrowing is active in the current buffer, only export its -narrowed part. - -If a region is active, export that region. - -When optional argument SUBTREEP is non-nil, export the sub-tree -at point, extracting information from the headline properties -first. - -When optional argument VISIBLE-ONLY is non-nil, don't export -contents of hidden elements. - -When optional argument BODY-ONLY is non-nil, only write code -between \"\\begin{document}\" and \"\\end{document}\". - -EXT-PLIST, when provided, is a property list with external -parameters overriding Org default settings, but still inferior to -file-local settings. - -When optional argument PUB-DIR is set, use it as the publishing -directory. - -Return PDF file's name." - (interactive) - (org-e-latex-compile - (org-e-latex-export-to-latex - subtreep visible-only body-only ext-plist pub-dir))) - -(defun org-e-latex-compile (texfile) - "Compile a TeX file. - -TEXFILE is the name of the file being compiled. Processing is -done through the command specified in `org-e-latex-pdf-process'. - -Return PDF file name or an error if it couldn't be produced." - (let* ((wconfig (current-window-configuration)) - (texfile (file-truename texfile)) - (base (file-name-sans-extension texfile)) - errors) - (message (format "Processing LaTeX file %s ..." texfile)) - (unwind-protect - (progn - (cond - ;; A function is provided: Apply it. - ((functionp org-e-latex-pdf-process) - (funcall org-e-latex-pdf-process (shell-quote-argument texfile))) - ;; A list is provided: Replace %b, %f and %o with appropriate - ;; values in each command before applying it. Output is - ;; redirected to "*Org PDF LaTeX Output*" buffer. - ((consp org-e-latex-pdf-process) - (let* ((out-dir (or (file-name-directory texfile) "./")) - (outbuf (get-buffer-create "*Org PDF LaTeX Output*"))) - (mapc - (lambda (command) - (shell-command - (replace-regexp-in-string - "%b" (shell-quote-argument base) - (replace-regexp-in-string - "%f" (shell-quote-argument texfile) - (replace-regexp-in-string - "%o" (shell-quote-argument out-dir) command t t) t t) t t) - outbuf)) - org-e-latex-pdf-process) - ;; Collect standard errors from output buffer. - (setq errors (org-e-latex--collect-errors outbuf)))) - (t (error "No valid command to process to PDF"))) - (let ((pdffile (concat base ".pdf"))) - ;; Check for process failure. Provide collected errors if - ;; possible. - (if (not (file-exists-p pdffile)) - (error (concat (format "PDF file %s wasn't produced" pdffile) - (when errors (concat ": " errors)))) - ;; Else remove log files, when specified, and signal end of - ;; process to user, along with any error encountered. - (when org-e-latex-remove-logfiles - (dolist (ext org-e-latex-logfiles-extensions) - (let ((file (concat base "." ext))) - (when (file-exists-p file) (delete-file file))))) - (message (concat "Process completed" - (if (not errors) "." - (concat " with errors: " errors))))) - ;; Return output file name. - pdffile)) - (set-window-configuration wconfig)))) - -(defun org-e-latex--collect-errors (buffer) - "Collect some kind of errors from \"pdflatex\" command output. - -BUFFER is the buffer containing output. - -Return collected error types as a string, or nil if there was -none." - (with-current-buffer buffer - (save-excursion - (goto-char (point-max)) - ;; Find final "pdflatex" run. - (when (re-search-backward "^[ \t]*This is pdf.*?TeX.*?Version" nil t) - (let ((case-fold-search t) - (errors "")) - (when (save-excursion - (re-search-forward "Reference.*?undefined" nil t)) - (setq errors (concat errors " [undefined reference]"))) - (when (save-excursion - (re-search-forward "Citation.*?undefined" nil t)) - (setq errors (concat errors " [undefined citation]"))) - (when (save-excursion - (re-search-forward "Undefined control sequence" nil t)) - (setq errors (concat errors " [undefined control sequence]"))) - (when (save-excursion - (re-search-forward "^! LaTeX.*?Error" nil t)) - (setq errors (concat errors " [LaTeX error]"))) - (when (save-excursion - (re-search-forward "^! Package.*?Error" nil t)) - (setq errors (concat errors " [package error]"))) - (and (org-string-nw-p errors) (org-trim errors))))))) - - -(provide 'org-e-latex) -;;; org-e-latex.el ends here diff --git a/contrib/lisp/org-e-odt.el b/contrib/lisp/org-e-odt.el deleted file mode 100644 index b2f7479..0000000 --- a/contrib/lisp/org-e-odt.el +++ /dev/null @@ -1,3762 +0,0 @@ -;;; org-e-odt.el --- OpenDocument Text exporter for Org-mode - -;; Copyright (C) 2010-2012 Free Software Foundation, Inc. - -;; Author: Jambunathan K <kjambunathan at gmail dot com> -;; Keywords: outlines, hypermedia, calendar, wp -;; Homepage: http://orgmode.org - -;; This file is not part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -(eval-when-compile - (require 'cl) - (require 'table)) -(require 'format-spec) -(require 'org-export) - -;;; Define Back-End - -(org-export-define-backend e-odt - ((bold . org-e-odt-bold) - (center-block . org-e-odt-center-block) - (clock . org-e-odt-clock) - (code . org-e-odt-code) - (drawer . org-e-odt-drawer) - (dynamic-block . org-e-odt-dynamic-block) - (entity . org-e-odt-entity) - (example-block . org-e-odt-example-block) - (export-block . org-e-odt-export-block) - (export-snippet . org-e-odt-export-snippet) - (fixed-width . org-e-odt-fixed-width) - (footnote-definition . org-e-odt-footnote-definition) - (footnote-reference . org-e-odt-footnote-reference) - (headline . org-e-odt-headline) - (horizontal-rule . org-e-odt-horizontal-rule) - (inline-src-block . org-e-odt-inline-src-block) - (inlinetask . org-e-odt-inlinetask) - (italic . org-e-odt-italic) - (item . org-e-odt-item) - (keyword . org-e-odt-keyword) - (latex-environment . org-e-odt-latex-environment) - (latex-fragment . org-e-odt-latex-fragment) - (line-break . org-e-odt-line-break) - (link . org-e-odt-link) - (macro . org-e-odt-macro) - (paragraph . org-e-odt-paragraph) - (plain-list . org-e-odt-plain-list) - (plain-text . org-e-odt-plain-text) - (planning . org-e-odt-planning) - (property-drawer . org-e-odt-property-drawer) - (quote-block . org-e-odt-quote-block) - (quote-section . org-e-odt-quote-section) - (radio-target . org-e-odt-radio-target) - (section . org-e-odt-section) - (special-block . org-e-odt-special-block) - (src-block . org-e-odt-src-block) - (statistics-cookie . org-e-odt-statistics-cookie) - (strike-through . org-e-odt-strike-through) - (subscript . org-e-odt-subscript) - (superscript . org-e-odt-superscript) - (table . org-e-odt-table) - (table-cell . org-e-odt-table-cell) - (table-row . org-e-odt-table-row) - (target . org-e-odt-target) - (template . org-e-odt-template) - (timestamp . org-e-odt-timestamp) - (underline . org-e-odt-underline) - (verbatim . org-e-odt-verbatim) - (verse-block . org-e-odt-verse-block)) - :export-block "ODT" - :options-alist - ((:odt-styles-file "ODT_STYLES_FILE" nil nil t) - (:LaTeX-fragments nil "LaTeX" org-export-with-LaTeX-fragments))) - - -;;; Dependencies - -;;; Hooks - -;;; Function Declarations - -(declare-function org-id-find-id-file "org-id" (id)) -(declare-function hfy-face-to-style "htmlfontify" (fn)) -(declare-function hfy-face-or-def-to-name "htmlfontify" (fn)) -(declare-function archive-zip-extract "arc-mode.el" (archive name)) -(declare-function org-create-math-formula "org" (latex-frag &optional mathml-file)) -(declare-function browse-url-file-url "browse-url" (file)) - - - - -;;; Internal Variables - -(defconst org-e-odt-lib-dir - (file-name-directory load-file-name) - "Location of ODT exporter. -Use this to infer values of `org-e-odt-styles-dir' and -`org-e-odt-schema-dir'.") - -(defvar org-e-odt-data-dir - (expand-file-name "../../etc/" org-e-odt-lib-dir) - "Data directory for ODT exporter. -Use this to infer values of `org-e-odt-styles-dir' and -`org-e-odt-schema-dir'.") - -(defconst org-e-odt-special-string-regexps - '(("\\\\-" . "­\\1") ; shy - ("---\\([^-]\\)" . "—\\1") ; mdash - ("--\\([^-]\\)" . "–\\1") ; ndash - ("\\.\\.\\." . "…")) ; hellip - "Regular expressions for special string conversion.") - -(defconst org-e-odt-schema-dir-list - (list - (and org-e-odt-data-dir - (expand-file-name "./schema/" org-e-odt-data-dir)) ; bail out - (eval-when-compile - (and (boundp 'org-e-odt-data-dir) org-e-odt-data-dir ; see make install - (expand-file-name "./schema/" org-e-odt-data-dir)))) - "List of directories to search for OpenDocument schema files. -Use this list to set the default value of -`org-e-odt-schema-dir'. The entries in this list are -populated heuristically based on the values of `org-e-odt-lib-dir' -and `org-e-odt-data-dir'.") - -(defconst org-e-odt-styles-dir-list - (list - (and org-e-odt-data-dir - (expand-file-name "./styles/" org-e-odt-data-dir)) ; bail out - (eval-when-compile - (and (boundp 'org-e-odt-data-dir) org-e-odt-data-dir ; see make install - (expand-file-name "./styles/" org-e-odt-data-dir))) - (expand-file-name "../../etc/styles/" org-e-odt-lib-dir) ; git - (expand-file-name "./etc/styles/" org-e-odt-lib-dir) ; elpa - (expand-file-name "./org/" data-directory) ; system - ) - "List of directories to search for OpenDocument styles files. -See `org-e-odt-styles-dir'. The entries in this list are populated -heuristically based on the values of `org-e-odt-lib-dir' and -`org-e-odt-data-dir'.") - -(defconst org-e-odt-styles-dir - (let* ((styles-dir - (catch 'styles-dir - (message "Debug (org-e-odt): Searching for OpenDocument styles files...") - (mapc (lambda (styles-dir) - (when styles-dir - (message "Debug (org-e-odt): Trying %s..." styles-dir) - (when (and (file-readable-p - (expand-file-name - "OrgOdtContentTemplate.xml" styles-dir)) - (file-readable-p - (expand-file-name - "OrgOdtStyles.xml" styles-dir))) - (message "Debug (org-e-odt): Using styles under %s" - styles-dir) - (throw 'styles-dir styles-dir)))) - org-e-odt-styles-dir-list) - nil))) - (unless styles-dir - (error "Error (org-e-odt): Cannot find factory styles files, aborting")) - styles-dir) - "Directory that holds auxiliary XML files used by the ODT exporter. - -This directory contains the following XML files - - \"OrgOdtStyles.xml\" and \"OrgOdtContentTemplate.xml\". These - XML files are used as the default values of - `org-e-odt-styles-file' and - `org-e-odt-content-template-file'. - -The default value of this variable varies depending on the -version of org in use and is initialized from -`org-e-odt-styles-dir-list'. Note that the user could be using org -from one of: org's own private git repository, GNU ELPA tar or -standard Emacs.") - -(defconst org-e-odt-bookmark-prefix "OrgXref.") - -(defconst org-e-odt-manifest-file-entry-tag - "\n<manifest:file-entry manifest:media-type=\"%s\" manifest:full-path=\"%s\"%s/>") - -(defconst org-e-odt-file-extensions - '(("odt" . "OpenDocument Text") - ("ott" . "OpenDocument Text Template") - ("odm" . "OpenDocument Master Document") - ("ods" . "OpenDocument Spreadsheet") - ("ots" . "OpenDocument Spreadsheet Template") - ("odg" . "OpenDocument Drawing (Graphics)") - ("otg" . "OpenDocument Drawing Template") - ("odp" . "OpenDocument Presentation") - ("otp" . "OpenDocument Presentation Template") - ("odi" . "OpenDocument Image") - ("odf" . "OpenDocument Formula") - ("odc" . "OpenDocument Chart"))) - -(defvar org-e-odt-table-style-format - " -<style:style style:name=\"%s\" style:family=\"table\"> - <style:table-properties style:rel-width=\"%d%%\" fo:margin-top=\"0cm\" fo:margin-bottom=\"0.20cm\" table:align=\"center\"/> -</style:style> -" - "Template for auto-generated Table styles.") - -(defvar org-e-odt-automatic-styles '() - "Registry of automatic styles for various OBJECT-TYPEs. -The variable has the following form: -\(\(OBJECT-TYPE-A - \(\(OBJECT-NAME-A.1 OBJECT-PROPS-A.1\) - \(OBJECT-NAME-A.2 OBJECT-PROPS-A.2\) ...\)\) - \(OBJECT-TYPE-B - \(\(OBJECT-NAME-B.1 OBJECT-PROPS-B.1\) - \(OBJECT-NAME-B.2 OBJECT-PROPS-B.2\) ...\)\) - ...\). - -OBJECT-TYPEs could be \"Section\", \"Table\", \"Figure\" etc. -OBJECT-PROPS is (typically) a plist created by passing -\"#+ATTR_ODT: \" option to `org-e-odt-parse-block-attributes'. - -Use `org-e-odt-add-automatic-style' to add update this variable.'") - -(defvar org-e-odt-object-counters nil - "Running counters for various OBJECT-TYPEs. -Use this to generate automatic names and style-names. See -`org-e-odt-add-automatic-style'.") - -(defvar org-e-odt-src-block-paragraph-format - "<style:style style:name=\"OrgSrcBlock\" style:family=\"paragraph\" style:parent-style-name=\"Preformatted_20_Text\"> - <style:paragraph-properties fo:background-color=\"%s\" fo:padding=\"0.049cm\" fo:border=\"0.51pt solid #000000\" style:shadow=\"none\"> - <style:background-image/> - </style:paragraph-properties> - <style:text-properties fo:color=\"%s\"/> - </style:style>" - "Custom paragraph style for colorized source and example blocks. -This style is much the same as that of \"OrgFixedWidthBlock\" -except that the foreground and background colors are set -according to the default face identified by the `htmlfontify'.") - -(defvar hfy-optimisations) -(defvar org-e-odt-embedded-formulas-count 0) -(defvar org-e-odt-entity-frame-styles - '(("As-CharImage" "__Figure__" ("OrgInlineImage" nil "as-char")) - ("ParagraphImage" "__Figure__" ("OrgDisplayImage" nil "paragraph")) - ("PageImage" "__Figure__" ("OrgPageImage" nil "page")) - ("CaptionedAs-CharImage" "__Figure__" - ("OrgCaptionedImage" - " style:rel-width=\"100%\" style:rel-height=\"scale\"" "paragraph") - ("OrgInlineImage" nil "as-char")) - ("CaptionedParagraphImage" "__Figure__" - ("OrgCaptionedImage" - " style:rel-width=\"100%\" style:rel-height=\"scale\"" "paragraph") - ("OrgImageCaptionFrame" nil "paragraph")) - ("CaptionedPageImage" "__Figure__" - ("OrgCaptionedImage" - " style:rel-width=\"100%\" style:rel-height=\"scale\"" "paragraph") - ("OrgPageImageCaptionFrame" nil "page")) - ("InlineFormula" "__MathFormula__" ("OrgInlineFormula" nil "as-char")) - ("DisplayFormula" "__MathFormula__" ("OrgDisplayFormula" nil "as-char")) - ("CaptionedDisplayFormula" "__MathFormula__" - ("OrgCaptionedFormula" nil "paragraph") - ("OrgFormulaCaptionFrame" nil "as-char")))) - -(defvar org-e-odt-embedded-images-count 0) -(defvar org-e-odt-image-size-probe-method - (append (and (executable-find "identify") '(imagemagick)) ; See Bug#10675 - '(emacs fixed)) - "Ordered list of methods for determining image sizes.") - -(defvar org-e-odt-default-image-sizes-alist - '(("as-char" . (5 . 0.4)) - ("paragraph" . (5 . 5))) - "Hardcoded image dimensions one for each of the anchor - methods.") - -;; A4 page size is 21.0 by 29.7 cms -;; The default page settings has 2cm margin on each of the sides. So -;; the effective text area is 17.0 by 25.7 cm -(defvar org-e-odt-max-image-size '(17.0 . 20.0) - "Limiting dimensions for an embedded image.") - -(defvar org-e-odt-label-styles - '(("math-formula" "%c" "text" "(%n)") - ("math-label" "(%n)" "text" "(%n)") - ("category-and-value" "%e %n: %c" "category-and-value" "%e %n") - ("value" "%e %n: %c" "value" "%n")) - "Specify how labels are applied and referenced. -This is an alist where each element is of the -form (LABEL-STYLE-NAME LABEL-ATTACH-FMT LABEL-REF-MODE -LABEL-REF-FMT). - -LABEL-ATTACH-FMT controls how labels and captions are attached to -an entity. It may contain following specifiers - %e, %n and %c. -%e is replaced with the CATEGORY-NAME. %n is replaced with -\"<text:sequence ...> SEQNO </text:sequence>\". %c is replaced -with CAPTION. See `org-e-odt-format-label-definition'. - -LABEL-REF-MODE and LABEL-REF-FMT controls how label references -are generated. The following XML is generated for a label -reference - \"<text:sequence-ref -text:reference-format=\"LABEL-REF-MODE\" ...> LABEL-REF-FMT -</text:sequence-ref>\". LABEL-REF-FMT may contain following -specifiers - %e and %n. %e is replaced with the CATEGORY-NAME. -%n is replaced with SEQNO. See -`org-e-odt-format-label-reference'.") - -(defvar org-e-odt-category-map-alist - '(("__Table__" "Table" "value" "Table") - ("__Figure__" "Illustration" "value" "Figure") - ("__MathFormula__" "Text" "math-formula" "Equation") - ("__DvipngImage__" "Equation" "value" "Equation") - ("__Listing__" "Listing" "value" "Listing") - ;; ("__Table__" "Table" "category-and-value") - ;; ("__Figure__" "Figure" "category-and-value") - ;; ("__DvipngImage__" "Equation" "category-and-value") - ) - "Map a CATEGORY-HANDLE to OD-VARIABLE and LABEL-STYLE. -This is a list where each entry is of the form \\(CATEGORY-HANDLE -OD-VARIABLE LABEL-STYLE CATEGORY-NAME\\). CATEGORY_HANDLE -identifies the captionable entity in question. OD-VARIABLE is -the OpenDocument sequence counter associated with the entity. -These counters are declared within -\"<text:sequence-decls>...</text:sequence-decls>\" block of -`org-e-odt-content-template-file'. LABEL-STYLE is a key into -`org-e-odt-label-styles' and specifies how a given entity should -be captioned and referenced. CATEGORY-NAME is used for -qualifying captions on export. You can modify the CATEGORY-NAME -used in the exported document by modifying -`org-export-dictionary'. For example, an embedded image in an -English document is captioned as \"Figure 1: Orgmode Logo\", by -default. If you want the image to be captioned as \"Illustration -1: Orgmode Logo\" instead, install an entry in -`org-export-dictionary' which translates \"Figure\" to -\"Illustration\" when the language is \"en\" and encoding is -`:utf-8'.") - -(defvar org-e-odt-manifest-file-entries nil) -(defvar hfy-user-sheet-assoc) - -(defvar org-e-odt-zip-dir nil - "Temporary work directory for OpenDocument exporter.") - - - -;;; User Configuration Variables - -(defgroup org-export-e-odt nil - "Options for exporting Org mode files to ODT." - :tag "Org Export ODT" - :group 'org-export) - - -;;;; Debugging - -(defcustom org-e-odt-prettify-xml nil - "Specify whether or not the xml output should be prettified. -When this option is turned on, `indent-region' is run on all -component xml buffers before they are saved. Turn this off for -regular use. Turn this on if you need to examine the xml -visually." - :group 'org-export-e-odt - :version "24.1" - :type 'boolean) - - -;;;; Document schema - -(defcustom org-e-odt-schema-dir - (let* ((schema-dir - (catch 'schema-dir - (message "Debug (org-e-odt): Searching for OpenDocument schema files...") - (mapc - (lambda (schema-dir) - (when schema-dir - (message "Debug (org-e-odt): Trying %s..." schema-dir) - (when (and (file-readable-p - (expand-file-name "od-manifest-schema-v1.2-cs01.rnc" - schema-dir)) - (file-readable-p - (expand-file-name "od-schema-v1.2-cs01.rnc" - schema-dir)) - (file-readable-p - (expand-file-name "schemas.xml" schema-dir))) - (message "Debug (org-e-odt): Using schema files under %s" - schema-dir) - (throw 'schema-dir schema-dir)))) - org-e-odt-schema-dir-list) - (message "Debug (org-e-odt): No OpenDocument schema files installed") - nil))) - schema-dir) - "Directory that contains OpenDocument schema files. - -This directory contains: -1. rnc files for OpenDocument schema -2. a \"schemas.xml\" file that specifies locating rules needed - for auto validation of OpenDocument XML files. - -Use the customize interface to set this variable. This ensures -that `rng-schema-locating-files' is updated and auto-validation -of OpenDocument XML takes place based on the value -`rng-nxml-auto-validate-flag'. - -The default value of this variable varies depending on the -version of org in use and is initialized from -`org-e-odt-schema-dir-list'. The OASIS schema files are available -only in the org's private git repository. It is *not* bundled -with GNU ELPA tar or standard Emacs distribution." - :type '(choice - (const :tag "Not set" nil) - (directory :tag "Schema directory")) - :group 'org-export-e-odt - :version "24.1" - :set - (lambda (var value) - "Set `org-e-odt-schema-dir'. -Also add it to `rng-schema-locating-files'." - (let ((schema-dir value)) - (set var - (if (and - (file-readable-p - (expand-file-name "od-manifest-schema-v1.2-cs01.rnc" schema-dir)) - (file-readable-p - (expand-file-name "od-schema-v1.2-cs01.rnc" schema-dir)) - (file-readable-p - (expand-file-name "schemas.xml" schema-dir))) - schema-dir - (when value - (message "Error (org-e-odt): %s has no OpenDocument schema files" - value)) - nil))) - (when org-e-odt-schema-dir - (eval-after-load 'rng-loc - '(add-to-list 'rng-schema-locating-files - (expand-file-name "schemas.xml" - org-e-odt-schema-dir)))))) - - -;;;; Document styles - -(defcustom org-e-odt-content-template-file nil - "Template file for \"content.xml\". -The exporter embeds the exported content just before -\"</office:text>\" element. - -If unspecified, the file named \"OrgOdtContentTemplate.xml\" -under `org-e-odt-styles-dir' is used." - :type 'file - :group 'org-export-e-odt - :version "24.1") - -(defcustom org-e-odt-styles-file nil - "Default styles file for use with ODT export. -Valid values are one of: -1. nil -2. path to a styles.xml file -3. path to a *.odt or a *.ott file -4. list of the form (ODT-OR-OTT-FILE (FILE-MEMBER-1 FILE-MEMBER-2 -...)) - -In case of option 1, an in-built styles.xml is used. See -`org-e-odt-styles-dir' for more information. - -In case of option 3, the specified file is unzipped and the -styles.xml embedded therein is used. - -In case of option 4, the specified ODT-OR-OTT-FILE is unzipped -and FILE-MEMBER-1, FILE-MEMBER-2 etc are copied in to the -generated odt file. Use relative path for specifying the -FILE-MEMBERS. styles.xml must be specified as one of the -FILE-MEMBERS. - -Use options 1, 2 or 3 only if styles.xml alone suffices for -achieving the desired formatting. Use option 4, if the styles.xml -references additional files like header and footer images for -achieving the desired formatting. - -Use \"#+ODT_STYLES_FILE: ...\" directive to set this variable on -a per-file basis. For example, - -#+ODT_STYLES_FILE: \"/path/to/styles.xml\" or -#+ODT_STYLES_FILE: (\"/path/to/file.ott\" (\"styles.xml\" \"image/hdr.png\"))." - :group 'org-export-e-odt - :version "24.1" - :type - '(choice - (const :tag "Factory settings" nil) - (file :must-match t :tag "styles.xml") - (file :must-match t :tag "ODT or OTT file") - (list :tag "ODT or OTT file + Members" - (file :must-match t :tag "ODF Text or Text Template file") - (cons :tag "Members" - (file :tag " Member" "styles.xml") - (repeat (file :tag "Member")))))) - -(defcustom org-e-odt-display-outline-level 2 - "Outline levels considered for enumerating captioned entities." - :group 'org-export-e-odt - :version "24.2" - :type 'integer) - -;;;; Document conversion - -(defcustom org-e-odt-convert-processes - '(("LibreOffice" - "soffice --headless --convert-to %f%x --outdir %d %i") - ("unoconv" - "unoconv -f %f -o %d %i")) - "Specify a list of document converters and their usage. -The converters in this list are offered as choices while -customizing `org-e-odt-convert-process'. - -This variable is a list where each element is of the -form (CONVERTER-NAME CONVERTER-CMD). CONVERTER-NAME is the name -of the converter. CONVERTER-CMD is the shell command for the -converter and can contain format specifiers. These format -specifiers are interpreted as below: - -%i input file name in full -%I input file name as a URL -%f format of the output file -%o output file name in full -%O output file name as a URL -%d output dir in full -%D output dir as a URL. -%x extra options as set in `org-e-odt-convert-capabilities'." - :group 'org-export-e-odt - :version "24.1" - :type - '(choice - (const :tag "None" nil) - (alist :tag "Converters" - :key-type (string :tag "Converter Name") - :value-type (group (string :tag "Command line"))))) - -(defcustom org-e-odt-convert-process "LibreOffice" - "Use this converter to convert from \"odt\" format to other formats. -During customization, the list of converter names are populated -from `org-e-odt-convert-processes'." - :group 'org-export-e-odt - :version "24.1" - :type '(choice :convert-widget - (lambda (w) - (apply 'widget-convert (widget-type w) - (eval (car (widget-get w :args))))) - `((const :tag "None" nil) - ,@(mapcar (lambda (c) - `(const :tag ,(car c) ,(car c))) - org-e-odt-convert-processes)))) - -(defcustom org-e-odt-convert-capabilities - '(("Text" - ("odt" "ott" "doc" "rtf" "docx") - (("pdf" "pdf") ("odt" "odt") ("rtf" "rtf") ("ott" "ott") - ("doc" "doc" ":\"MS Word 97\"") ("docx" "docx") ("html" "html"))) - ("Web" - ("html") - (("pdf" "pdf") ("odt" "odt") ("html" "html"))) - ("Spreadsheet" - ("ods" "ots" "xls" "csv" "xlsx") - (("pdf" "pdf") ("ots" "ots") ("html" "html") ("csv" "csv") ("ods" "ods") - ("xls" "xls") ("xlsx" "xlsx"))) - ("Presentation" - ("odp" "otp" "ppt" "pptx") - (("pdf" "pdf") ("swf" "swf") ("odp" "odp") ("otp" "otp") ("ppt" "ppt") - ("pptx" "pptx") ("odg" "odg")))) - "Specify input and output formats of `org-e-odt-convert-process'. -More correctly, specify the set of input and output formats that -the user is actually interested in. - -This variable is an alist where each element is of the -form (DOCUMENT-CLASS INPUT-FMT-LIST OUTPUT-FMT-ALIST). -INPUT-FMT-LIST is a list of INPUT-FMTs. OUTPUT-FMT-ALIST is an -alist where each element is of the form (OUTPUT-FMT -OUTPUT-FILE-EXTENSION EXTRA-OPTIONS). - -The variable is interpreted as follows: -`org-e-odt-convert-process' can take any document that is in -INPUT-FMT-LIST and produce any document that is in the -OUTPUT-FMT-LIST. A document converted to OUTPUT-FMT will have -OUTPUT-FILE-EXTENSION as the file name extension. OUTPUT-FMT -serves dual purposes: -- It is used for populating completion candidates during - `org-e-odt-convert' commands. -- It is used as the value of \"%f\" specifier in - `org-e-odt-convert-process'. - -EXTRA-OPTIONS is used as the value of \"%x\" specifier in -`org-e-odt-convert-process'. - -DOCUMENT-CLASS is used to group a set of file formats in -INPUT-FMT-LIST in to a single class. - -Note that this variable inherently captures how LibreOffice based -converters work. LibreOffice maps documents of various formats -to classes like Text, Web, Spreadsheet, Presentation etc and -allow document of a given class (irrespective of it's source -format) to be converted to any of the export formats associated -with that class. - -See default setting of this variable for an typical -configuration." - :group 'org-export-e-odt - :version "24.1" - :type - '(choice - (const :tag "None" nil) - (alist :tag "Capabilities" - :key-type (string :tag "Document Class") - :value-type - (group (repeat :tag "Input formats" (string :tag "Input format")) - (alist :tag "Output formats" - :key-type (string :tag "Output format") - :value-type - (group (string :tag "Output file extension") - (choice - (const :tag "None" nil) - (string :tag "Extra options")))))))) - -(defcustom org-e-odt-preferred-output-format nil - "Automatically post-process to this format after exporting to \"odt\". -Interactive commands `org-export-as-e-odt' and -`org-export-as-e-odt-and-open' export first to \"odt\" format and -then use `org-e-odt-convert-process' to convert the -resulting document to this format. During customization of this -variable, the list of valid values are populated based on -`org-e-odt-convert-capabilities'." - :group 'org-export-e-odt - :version "24.1" - :type '(choice :convert-widget - (lambda (w) - (apply 'widget-convert (widget-type w) - (eval (car (widget-get w :args))))) - `((const :tag "None" nil) - ,@(mapcar (lambda (c) - `(const :tag ,c ,c)) - (org-e-odt-reachable-formats "odt"))))) - - -;;;; Drawers - -(defcustom org-e-odt-format-drawer-function nil - "Function called to format a drawer in HTML code. - -The function must accept two parameters: - NAME the drawer name, like \"LOGBOOK\" - CONTENTS the contents of the drawer. - -The function should return the string to be exported. - -For example, the variable could be set to the following function -in order to mimic default behaviour: - -\(defun org-e-odt-format-drawer-default \(name contents\) - \"Format a drawer element for HTML export.\" - contents\)" - :group 'org-export-e-odt - :type 'function) - - -;;;; Headline - -(defcustom org-e-odt-format-headline-function nil - "Function to format headline text. - -This function will be called with 5 arguments: -TODO the todo keyword \(string or nil\). -TODO-TYPE the type of todo \(symbol: `todo', `done', nil\) -PRIORITY the priority of the headline \(integer or nil\) -TEXT the main headline text \(string\). -TAGS the tags string, separated with colons \(string or nil\). - -The function result will be used in the section format string. - -As an example, one could set the variable to the following, in -order to reproduce the default set-up: - -\(defun org-e-odt-format-headline \(todo todo-type priority text tags\) - \"Default format function for an headline.\" - \(concat \(when todo - \(format \"\\\\textbf{\\\\textsc{\\\\textsf{%s}}} \" todo\)\) - \(when priority - \(format \"\\\\framebox{\\\\#%c} \" priority\)\) - text - \(when tags \(format \"\\\\hfill{}\\\\textsc{%s}\" tags\)\)\)\)" - :group 'org-export-e-odt - :type 'function) - - -;;;; Inlinetasks - -(defcustom org-e-odt-format-inlinetask-function nil - "Function called to format an inlinetask in HTML code. - -The function must accept six parameters: - TODO the todo keyword, as a string - TODO-TYPE the todo type, a symbol among `todo', `done' and nil. - PRIORITY the inlinetask priority, as a string - NAME the inlinetask name, as a string. - TAGS the inlinetask tags, as a string. - CONTENTS the contents of the inlinetask, as a string. - -The function should return the string to be exported. - -For example, the variable could be set to the following function -in order to mimic default behaviour: - -\(defun org-e-odt-format-inlinetask \(todo type priority name tags contents\) -\"Format an inline task element for HTML export.\" - \(let \(\(full-title - \(concat - \(when todo - \(format \"\\\\textbf{\\\\textsf{\\\\textsc{%s}}} \" todo\)\) - \(when priority \(format \"\\\\framebox{\\\\#%c} \" priority\)\) - title - \(when tags \(format \"\\\\hfill{}\\\\textsc{%s}\" tags\)\)\)\)\) - \(format \(concat \"\\\\begin{center}\\n\" - \"\\\\fbox{\\n\" - \"\\\\begin{minipage}[c]{.6\\\\textwidth}\\n\" - \"%s\\n\\n\" - \"\\\\rule[.8em]{\\\\textwidth}{2pt}\\n\\n\" - \"%s\" - \"\\\\end{minipage}}\" - \"\\\\end{center}\"\) - full-title contents\)\)" - :group 'org-export-e-odt - :type 'function) - - -;;;; Links - -(defcustom org-e-odt-inline-image-rules - '(("file" . "\\.\\(jpeg\\|jpg\\|png\\|gif\\)\\'")) - "Rules characterizing image files that can be inlined into HTML. - -A rule consists in an association whose key is the type of link -to consider, and value is a regexp that will be matched against -link's path. - -Note that, by default, the image extension *actually* allowed -depend on the way the HTML file is processed. When used with -pdflatex, pdf, jpg and png images are OK. When processing -through dvi to Postscript, only ps and eps are allowed. The -default we use here encompasses both." - :group 'org-export-e-odt - :type '(alist :key-type (string :tag "Type") - :value-type (regexp :tag "Path"))) - -(defcustom org-e-odt-pixels-per-inch display-pixels-per-inch - "Scaling factor for converting images pixels to inches. -Use this for sizing of embedded images. See Info node `(org) -Images in ODT export' for more information." - :type 'float - :group 'org-export-e-odt - :version "24.1") - - -;;;; Plain text - -(defcustom org-e-odt-quotes - '(("fr" - ("\\(\\s-\\|[[(]\\|^\\)\"" . "« ") - ("\\(\\S-\\)\"" . "» ") - ("\\(\\s-\\|(\\|^\\)'" . "'")) - ("en" - ("\\(\\s-\\|[[(]\\|^\\)\"" . "“") - ("\\(\\S-\\)\"" . "”") - ("\\(\\s-\\|(\\|^\\)'" . "‘") - ("\\(\\S-\\)'" . "’"))) - "Alist for quotes to use when converting english double-quotes. - -The CAR of each item in this alist is the language code. -The CDR of each item in this alist is a list of three CONS: -- the first CONS defines the opening quote; -- the second CONS defines the closing quote; -- the last CONS defines single quotes. - -For each item in a CONS, the first string is a regexp -for allowed characters before/after the quote, the second -string defines the replacement string for this quote." - :group 'org-export-e-odt - :type '(list - (cons :tag "Opening quote" - (string :tag "Regexp for char before") - (string :tag "Replacement quote ")) - (cons :tag "Closing quote" - (string :tag "Regexp for char after ") - (string :tag "Replacement quote ")) - (cons :tag "Single quote" - (string :tag "Regexp for char before") - (string :tag "Replacement quote ")))) - - -;;;; Src Block - -(defcustom org-e-odt-create-custom-styles-for-srcblocks t - "Whether custom styles for colorized source blocks be automatically created. -When this option is turned on, the exporter creates custom styles -for source blocks based on the advice of `htmlfontify'. Creation -of custom styles happen as part of `org-e-odt-hfy-face-to-css'. - -When this option is turned off exporter does not create such -styles. - -Use the latter option if you do not want the custom styles to be -based on your current display settings. It is necessary that the -styles.xml already contains needed styles for colorizing to work. - -This variable is effective only if -`org-e-odt-fontify-srcblocks' is turned on." - :group 'org-export-e-odt - :version "24.1" - :type 'boolean) - -(defcustom org-e-odt-fontify-srcblocks t - "Specify whether or not source blocks need to be fontified. -Turn this option on if you want to colorize the source code -blocks in the exported file. For colorization to work, you need -to make available an enhanced version of `htmlfontify' library." - :type 'boolean - :group 'org-export-e-odt - :version "24.1") - - -;;;; Table - -(defcustom org-e-odt-table-caption-above t - "When non-nil, place caption string at the beginning of the table. -Otherwise, place it near the end." - :group 'org-export-e-odt - :type 'boolean) - -(defcustom org-e-odt-table-styles - '(("OrgEquation" "OrgEquation" - ((use-first-column-styles . t) - (use-last-column-styles . t)))) - "Specify how Table Styles should be derived from a Table Template. -This is a list where each element is of the -form (TABLE-STYLE-NAME TABLE-TEMPLATE-NAME TABLE-CELL-OPTIONS). - -TABLE-STYLE-NAME is the style associated with the table through -\"#+ATTR_ODT: :style TABLE-STYLE-NAME\" line. - -TABLE-TEMPLATE-NAME is a set of - upto 9 - automatic -TABLE-CELL-STYLE-NAMEs and PARAGRAPH-STYLE-NAMEs (as defined -below) that is included in -`org-e-odt-content-template-file'. - -TABLE-CELL-STYLE-NAME := TABLE-TEMPLATE-NAME + TABLE-CELL-TYPE + - \"TableCell\" -PARAGRAPH-STYLE-NAME := TABLE-TEMPLATE-NAME + TABLE-CELL-TYPE + - \"TableParagraph\" -TABLE-CELL-TYPE := \"FirstRow\" | \"LastColumn\" | - \"FirstRow\" | \"LastRow\" | - \"EvenRow\" | \"OddRow\" | - \"EvenColumn\" | \"OddColumn\" | \"\" -where \"+\" above denotes string concatenation. - -TABLE-CELL-OPTIONS is an alist where each element is of the -form (TABLE-CELL-STYLE-SELECTOR . ON-OR-OFF). -TABLE-CELL-STYLE-SELECTOR := `use-first-row-styles' | - `use-last-row-styles' | - `use-first-column-styles' | - `use-last-column-styles' | - `use-banding-rows-styles' | - `use-banding-columns-styles' | - `use-first-row-styles' -ON-OR-OFF := `t' | `nil' - -For example, with the following configuration - -\(setq org-e-odt-table-styles - '\(\(\"TableWithHeaderRowsAndColumns\" \"Custom\" - \(\(use-first-row-styles . t\) - \(use-first-column-styles . t\)\)\) - \(\"TableWithHeaderColumns\" \"Custom\" - \(\(use-first-column-styles . t\)\)\)\)\) - -1. A table associated with \"TableWithHeaderRowsAndColumns\" - style will use the following table-cell styles - - \"CustomFirstRowTableCell\", \"CustomFirstColumnTableCell\", - \"CustomTableCell\" and the following paragraph styles - \"CustomFirstRowTableParagraph\", - \"CustomFirstColumnTableParagraph\", \"CustomTableParagraph\" - as appropriate. - -2. A table associated with \"TableWithHeaderColumns\" style will - use the following table-cell styles - - \"CustomFirstColumnTableCell\", \"CustomTableCell\" and the - following paragraph styles - \"CustomFirstColumnTableParagraph\", \"CustomTableParagraph\" - as appropriate.. - -Note that TABLE-TEMPLATE-NAME corresponds to the -\"<table:table-template>\" elements contained within -\"<office:styles>\". The entries (TABLE-STYLE-NAME -TABLE-TEMPLATE-NAME TABLE-CELL-OPTIONS) correspond to -\"table:template-name\" and \"table:use-first-row-styles\" etc -attributes of \"<table:table>\" element. Refer ODF-1.2 -specification for more information. Also consult the -implementation filed under `org-e-odt-get-table-cell-styles'. - -The TABLE-STYLE-NAME \"OrgEquation\" is used internally for -formatting of numbered display equations. Do not delete this -style from the list." - :group 'org-export-e-odt - :version "24.1" - :type '(choice - (const :tag "None" nil) - (repeat :tag "Table Styles" - (list :tag "Table Style Specification" - (string :tag "Table Style Name") - (string :tag "Table Template Name") - (alist :options (use-first-row-styles - use-last-row-styles - use-first-column-styles - use-last-column-styles - use-banding-rows-styles - use-banding-columns-styles) - :key-type symbol - :value-type (const :tag "True" t)))))) - - - -;;; Internal functions - -;;;; Date - -(defun org-e-odt--date (&optional org-ts fmt) - (save-match-data - (let* ((time - (and (stringp org-ts) - (string-match org-ts-regexp0 org-ts) - (apply 'encode-time - (org-fix-decoded-time - (org-parse-time-string (match-string 0 org-ts) t))))) - date) - (cond - (fmt (format-time-string fmt time)) - (t (setq date (format-time-string "%Y-%m-%dT%H:%M:%S%z" time)) - (format "%s:%s" (substring date 0 -2) (substring date -2))))))) - -;;;; Frame - -(defun org-e-odt--frame (text width height style &optional extra - anchor-type) - (let ((frame-attrs - (concat - (if width (format " svg:width=\"%0.2fcm\"" width) "") - (if height (format " svg:height=\"%0.2fcm\"" height) "") - extra - (format " text:anchor-type=\"%s\"" (or anchor-type "paragraph"))))) - (format - "\n<draw:frame draw:style-name=\"%s\"%s>\n%s\n</draw:frame>" - style frame-attrs - (concat text - (let ((title (get-text-property 0 :title text)) - (desc (get-text-property 0 :description text))) - (concat (and title - (format "<svg:title>%s</svg:title>" - (org-e-odt-encode-plain-text title t))) - (and desc - (format "<svg:desc>%s</svg:desc>" - (org-e-odt-encode-plain-text desc t))))))))) - -;;;; Library wrappers - -(defun org-e-odt--adopt-elements (parent &rest children) - (prog1 parent - (mapc (lambda (child) - (let ((parent-1 (org-element-adopt-element parent child nil))) - (assert (eq parent-1 parent)))) - children))) - -(defun org-e-odt--zip-extract (archive members target) - (when (atom members) (setq members (list members))) - (mapc (lambda (archive member target) - (require 'arc-mode) - (let* ((--quote-file-name - ;; This is shamelessly stolen from `archive-zip-extract'. - (lambda (name) - (if (or (not (memq system-type '(windows-nt ms-dos))) - (and (boundp 'w32-quote-process-args) - (null w32-quote-process-args))) - (shell-quote-argument name) - name))) - (target (funcall --quote-file-name target)) - (archive (expand-file-name archive)) - (archive-zip-extract - (list "unzip" "-qq" "-o" "-d" target)) - exit-code command-output) - (setq command-output - (with-temp-buffer - (setq exit-code (archive-zip-extract archive member)) - (buffer-string))) - (unless (zerop exit-code) - (message command-output) - (error "Extraction failed")))) - members)) - -;;;; Textbox - -(defun org-e-odt--textbox (text width height style &optional - extra anchor-type) - (org-e-odt--frame - (format "\n<draw:text-box %s>%s\n</draw:text-box>" - (concat (format " fo:min-height=\"%0.2fcm\"" (or height .2)) - (and (not width) - (format " fo:min-width=\"%0.2fcm\"" (or width .2)))) - text) - width nil style extra anchor-type)) - - - -;;;; Table of Contents - -(defun org-e-odt-begin-toc (index-title depth) - (concat - (format " - <text:table-of-content text:style-name=\"Sect2\" text:protected=\"true\" text:name=\"Table of Contents1\"> - <text:table-of-content-source text:outline-level=\"%d\"> - <text:index-title-template text:style-name=\"Contents_20_Heading\">%s</text:index-title-template> -" depth index-title) - - (let ((levels (number-sequence 1 10))) - (mapconcat - (lambda (level) - (format - " - <text:table-of-content-entry-template text:outline-level=\"%d\" text:style-name=\"Contents_20_%d\"> - <text:index-entry-link-start text:style-name=\"Internet_20_link\"/> - <text:index-entry-chapter/> - <text:index-entry-text/> - <text:index-entry-link-end/> - </text:table-of-content-entry-template> -" level level)) levels "")) - - (format " - </text:table-of-content-source> - - <text:index-body> - <text:index-title text:style-name=\"Sect1\" text:name=\"Table of Contents1_Head\"> - <text:p text:style-name=\"Contents_20_Heading\">%s</text:p> - </text:index-title> - " index-title))) - -(defun org-e-odt-end-toc () - (format " - </text:index-body> - </text:table-of-content> -")) - - - -(defun* org-e-odt-format-toc-headline - (todo todo-type priority text tags - &key level section-number headline-label &allow-other-keys) - (setq text (concat - (and org-export-with-section-numbers - (concat section-number ". ")) - text - (and tags - (concat - "<text:tab/>" - (format "<text:span text:style-name=\"%s\">%s</text:span>" - "OrgTag" tags))))) - (when todo - (setq text (format "<text:span text:style-name=\"%s\">%s</text:span>" - "OrgTodo" text))) - (org-e-odt-format-link text (concat "#" headline-label) t)) - -(defun org-e-odt-toc (depth info) - (assert (wholenump depth)) - (let* ((title (org-export-translate "Table of Contents" :utf-8 info)) - (headlines (org-export-collect-headlines info depth))) - - (when headlines - (concat - (org-e-odt-begin-toc title depth) - - (mapconcat - (lambda (headline) - (let* ((entry (org-e-odt-format-headline--wrap - headline info 'org-e-odt-format-toc-headline)) - (level (org-export-get-relative-level headline info)) - (style (format "Contents_20_%d" level))) - (format "\n<text:p text:style-name=\"%s\">%s</text:p>" - style entry))) - headlines "\n") - - (org-e-odt-end-toc))))) - - -;;;; Document styles - -(defun org-e-odt-add-automatic-style (object-type &optional object-props) - "Create an automatic style of type OBJECT-TYPE with param OBJECT-PROPS. -OBJECT-PROPS is (typically) a plist created by passing -\"#+ATTR_ODT: \" option of the object in question to -`org-e-odt-parse-block-attributes'. - -Use `org-e-odt-object-counters' to generate an automatic -OBJECT-NAME and STYLE-NAME. If OBJECT-PROPS is non-nil, add a -new entry in `org-e-odt-automatic-styles'. Return (OBJECT-NAME -. STYLE-NAME)." - (assert (stringp object-type)) - (let* ((object (intern object-type)) - (seqvar object) - (seqno (1+ (or (plist-get org-e-odt-object-counters seqvar) 0))) - (object-name (format "%s%d" object-type seqno)) style-name) - (setq org-e-odt-object-counters - (plist-put org-e-odt-object-counters seqvar seqno)) - (when object-props - (setq style-name (format "Org%s" object-name)) - (setq org-e-odt-automatic-styles - (plist-put org-e-odt-automatic-styles object - (append (list (list style-name object-props)) - (plist-get org-e-odt-automatic-styles object))))) - (cons object-name style-name))) - - -;;;; Caption and Labels - - -(defun org-e-odt--wrap-label (element output) - "Wrap label associated to ELEMENT around OUTPUT, if appropriate. -This function shouldn't be used for floats. See -`org-e-odt--caption/label-string'." - ;; (let ((label (org-element-property :name element))) - ;; (if (or (not output) (not label) (string= output "") (string= label "")) - ;; output - ;; (concat (format "\\label{%s}\n" label) output))) - output) - - -(defun org-e-odt--caption/label-string (caption label info) - "Return caption and label HTML string for floats. - -CAPTION is a cons cell of secondary strings, the car being the -standard caption and the cdr its short form. LABEL is a string -representing the label. INFO is a plist holding contextual -information. - -If there's no caption nor label, return the empty string. - -For non-floats, see `org-e-odt--wrap-label'." - (setq label nil) ;; FIXME - - (let ((label-str (if label (format "\\label{%s}" label) ""))) - (cond - ((and (not caption) (not label)) "") - ((not caption) (format "\\label{%s}\n" label)) - ;; Option caption format with short name. - ((cdr caption) - (format "\\caption[%s]{%s%s}\n" - (org-export-data (cdr caption) info) - label-str - (org-export-data (car caption) info))) - ;; Standard caption format. - ;; (t (format "\\caption{%s%s}\n" - ;; label-str - ;; (org-export-data (car caption) info))) - (t (org-export-data (car caption) info))))) - -;;;; Checkbox - -(defun org-e-odt--checkbox (item) - "Return check-box string associated to ITEM." - (let ((checkbox (org-element-property :checkbox item))) - (if (not checkbox) "" - (format "<text:span text:style-name=\"%s\">%s</text:span>" - "OrgCode" (case checkbox - (on "[✓] ") ; CHECK MARK - (off "[ ] ") - (trans "[-] ")))))) - - - -;;; Template - -(defun org-e-odt-template (contents info) - "Return complete document string after HTML conversion. -CONTENTS is the transcoded contents string. RAW-DATA is the -original parsed data. INFO is a plist holding export options." - ;; Write meta file. - (let ((title (org-export-data (plist-get info :title) info)) - (author (let ((author (plist-get info :author))) - (if (not author) "" (org-export-data author info)))) - (date (org-e-odt--date - (org-export-data (plist-get info :date) info))) - (email (plist-get info :email)) - (keywords (plist-get info :keywords)) - (description (plist-get info :description))) - (write-region - (concat - "<?xml version=\"1.0\" encoding=\"UTF-8\"?> - <office:document-meta - xmlns:office=\"urn:oasis:names:tc:opendocument:xmlns:office:1.0\" - xmlns:xlink=\"http://www.w3.org/1999/xlink\" - xmlns:dc=\"http://purl.org/dc/elements/1.1/\" - xmlns:meta=\"urn:oasis:names:tc:opendocument:xmlns:meta:1.0\" - xmlns:ooo=\"http://openoffice.org/2004/office\" - office:version=\"1.2\"> - <office:meta>\n" - (format "<dc:creator>%s</dc:creator>\n" author) - (format "<meta:initial-creator>%s</meta:initial-creator>\n" author) - (format "<dc:date>%s</dc:date>\n" date) - (format "<meta:creation-date>%s</meta:creation-date>\n" date) - (format "<meta:generator>%s</meta:generator>\n" - (let ((creator-info (plist-get info :with-creator))) - (if (or (not creator-info) (eq creator-info 'comment)) "" - (plist-get info :creator)))) - (format "<meta:keyword>%s</meta:keyword>\n" keywords) - (format "<dc:subject>%s</dc:subject>\n" description) - (format "<dc:title>%s</dc:title>\n" title) - "\n" - " </office:meta>\n" "</office:document-meta>") - nil (concat org-e-odt-zip-dir "meta.xml")) - ;; Add meta.xml in to manifest. - (org-e-odt-create-manifest-file-entry "text/xml" "meta.xml")) - - ;; Update styles file. - ;; Copy styles.xml. Also dump htmlfontify styles, if there is any. - ;; Write styles file. - (let* ((styles-file (plist-get info :odt-styles-file)) - (styles-file (and styles-file (read (org-trim styles-file)))) - ;; Non-availability of styles.xml is not a critical - ;; error. For now throw an error purely for aesthetic - ;; reasons. - (styles-file (or styles-file - org-e-odt-styles-file - (expand-file-name "OrgOdtStyles.xml" - org-e-odt-styles-dir) - (error "org-e-odt: Missing styles file?")))) - (cond - ((listp styles-file) - (let ((archive (nth 0 styles-file)) - (members (nth 1 styles-file))) - (org-e-odt--zip-extract archive members org-e-odt-zip-dir) - (mapc - (lambda (member) - (when (org-file-image-p member) - (let* ((image-type (file-name-extension member)) - (media-type (format "image/%s" image-type))) - (org-e-odt-create-manifest-file-entry media-type member)))) - members))) - ((and (stringp styles-file) (file-exists-p styles-file)) - (let ((styles-file-type (file-name-extension styles-file))) - (cond - ((string= styles-file-type "xml") - (copy-file styles-file (concat org-e-odt-zip-dir "styles.xml") t)) - ((member styles-file-type '("odt" "ott")) - (org-e-odt--zip-extract styles-file "styles.xml" org-e-odt-zip-dir))))) - (t - (error (format "Invalid specification of styles.xml file: %S" - org-e-odt-styles-file)))) - - ;; create a manifest entry for styles.xml - (org-e-odt-create-manifest-file-entry "text/xml" "styles.xml") - - ;; FIXME: Who is opening an empty styles.xml before this point? - (with-current-buffer - (find-file-noselect (concat org-e-odt-zip-dir "styles.xml") t) - (revert-buffer t t) - - ;; Write custom styles for source blocks - ;; Save STYLES used for colorizing of source blocks. - ;; Update styles.xml with styles that were collected as part of - ;; `org-e-odt-hfy-face-to-css' callbacks. - (let ((styles (mapconcat (lambda (style) (format " %s\n" (cddr style))) - hfy-user-sheet-assoc ""))) - (when styles - (goto-char (point-min)) - (when (re-search-forward "</office:styles>" nil t) - (goto-char (match-beginning 0)) - (insert "\n<!-- Org Htmlfontify Styles -->\n" styles "\n")))) - - ;; Update styles.xml - take care of outline numbering - - ;; Don't make automatic backup of styles.xml file. This setting - ;; prevents the backed-up styles.xml file from being zipped in to - ;; odt file. This is more of a hackish fix. Better alternative - ;; would be to fix the zip command so that the output odt file - ;; includes only the needed files and excludes any auto-generated - ;; extra files like backups and auto-saves etc etc. Note that - ;; currently the zip command zips up the entire temp directory so - ;; that any auto-generated files created under the hood ends up in - ;; the resulting odt file. - (set (make-local-variable 'backup-inhibited) t) - - ;; Outline numbering is retained only upto LEVEL. - ;; To disable outline numbering pass a LEVEL of 0. - - (goto-char (point-min)) - (let ((regex - "<text:outline-level-style\\([^>]*\\)text:level=\"\\([^\"]*\\)\"\\([^>]*\\)>") - (replacement - "<text:outline-level-style\\1text:level=\"\\2\" style:num-format=\"\">")) - (while (re-search-forward regex nil t) - (unless (let ((sec-num (plist-get info :section-numbers)) - (level (string-to-number (match-string 2)))) - (if (wholenump sec-num) (<= level sec-num) sec-num)) - (replace-match replacement t nil)))) - (save-buffer 0))) - ;; Update content.xml. - (with-temp-buffer - (insert-file-contents - (or org-e-odt-content-template-file - (expand-file-name "OrgOdtContentTemplate.xml" - org-e-odt-styles-dir))) - ;; Write automatic styles. - ;; - Position the cursor. - (goto-char (point-min)) - (re-search-forward " </office:automatic-styles>" nil t) - (goto-char (match-beginning 0)) - ;; - Dump automatic table styles - (loop for (style-name props) in - (plist-get org-e-odt-automatic-styles 'Table) do - (when (setq props (or (plist-get props :rel-width) 96)) - (insert (format org-e-odt-table-style-format style-name props)))) - ;; Update display level. - ;; - Remove existing sequence decls. Also position the cursor. - (goto-char (point-min)) - (when (re-search-forward "<text:sequence-decls" nil t) - (delete-region (match-beginning 0) - (re-search-forward "</text:sequence-decls>" nil nil))) - ;; Update sequence decls according to user preference. - (insert - (format - "\n<text:sequence-decls>\n%s\n</text:sequence-decls>" - (mapconcat - (lambda (x) - (format - "<text:sequence-decl text:display-outline-level=\"%d\" text:name=\"%s\"/>" - org-e-odt-display-outline-level (nth 1 x))) - org-e-odt-category-map-alist "\n"))) - ;; Position the cursor to document body. - (goto-char (point-min)) - (re-search-forward "</office:text>" nil nil) - (goto-char (match-beginning 0)) - - ;; Preamble - Title, Author, Date etc. - (insert - (let* ((title (org-export-data (plist-get info :title) info)) - (author (and (plist-get info :with-author) - (let ((auth (plist-get info :author))) - (and auth (org-export-data auth info))))) - (date (org-export-data (plist-get info :date) info)) - (iso-date (org-e-odt--date date)) - (date (org-e-odt--date date "%d %b %Y")) - (email (plist-get info :email)) - ;; switch on or off above vars based on user settings - (author (and (plist-get info :with-author) (or author email))) - ;; (date (and (plist-get info :time-stamp-file) date)) - (email (and (plist-get info :with-email) email))) - (concat - ;; title - (when title - (concat - (format "\n<text:p text:style-name=\"%s\">%s</text:p>" - "OrgTitle" (format "\n<text:title>%s</text:title>" title)) - ;; separator - "\n<text:p text:style-name=\"OrgTitle\"/>")) - (cond - ((and author (not email)) - ;; author only - (concat - (format "\n<text:p text:style-name=\"%s\">%s</text:p>" - "OrgSubtitle" - (format "<text:initial-creator>%s</text:initial-creator>" author)) - ;; separator - "\n<text:p text:style-name=\"OrgSubtitle\"/>")) - ((and author email) - ;; author and email - (concat - (format "\n<text:p text:style-name=\"%s\">%s</text:p>" - "OrgSubtitle" - (org-e-odt-format-link - (format "<text:initial-creator>%s</text:initial-creator>" author) - (concat "mailto:" email))) - ;; separator - "\n<text:p text:style-name=\"OrgSubtitle\"/>"))) - ;; date - (when date - (concat - (format - "\n<text:p text:style-name=\"%s\">%s</text:p>" - "OrgSubtitle" - (format - "\n<text:date style:data-style-name=\"%s\" text:date-value=\"%s\">%s</text:date>" - - "N75" iso-date date)) - ;; separator - "<text:p text:style-name=\"OrgSubtitle\"/>"))))) - - ;; Table of Contents - (let ((depth (plist-get info :with-toc))) - (when (wholenump depth) (insert (org-e-odt-toc depth info)))) - ;; Contents. - (insert contents) - ;; Return contents. - (buffer-substring-no-properties (point-min) (point-max)))) - - - -;;; Transcode Functions - -;;;; Bold - -(defun org-e-odt-bold (bold contents info) - "Transcode BOLD from Org to ODT. -CONTENTS is the text with bold markup. INFO is a plist holding -contextual information." - (format "<text:span text:style-name=\"%s\">%s</text:span>" - "Bold" contents)) - - -;;;; Center Block - -(defun org-e-odt-center-block (center-block contents info) - "Transcode a CENTER-BLOCK element from Org to ODT. -CONTENTS holds the contents of the center block. INFO is a plist -holding contextual information." - (org-e-odt--wrap-label center-block contents)) - - -;;;; Clock - -(defun org-e-odt-clock (clock contents info) - "Transcode a CLOCK element from Org to ODT. -CONTENTS is nil. INFO is a plist used as a communication -channel." - (format "<text:span text:style-name=\"%s\">%s</text:span>" - "OrgTimestampWrapper" - (concat - (format "<text:span text:style-name=\"%s\">%s</text:span>" - "OrgTimestampKeyword" org-clock-string) - (format "<text:span text:style-name=\"%s\">%s</text:span>" - "OrgTimestamp" - (concat (org-translate-time - (org-element-property :value clock)) - (let ((time (org-element-property :time clock))) - (and time (format " (%s)" time)))))))) - - -;;;; Code - -(defun org-e-odt-code (code contents info) - "Transcode a CODE object from Org to ODT. -CONTENTS is nil. INFO is a plist used as a communication -channel." - (format "<text:span text:style-name=\"%s\">%s</text:span>" - "OrgCode" (org-element-property :value code))) - - -;;;; Comment - -;; Comments are ignored. - - -;;;; Comment Block - -;; Comment Blocks are ignored. - - -;;;; Drawer - -(defun org-e-odt-drawer (drawer contents info) - "Transcode a DRAWER element from Org to ODT. -CONTENTS holds the contents of the block. INFO is a plist -holding contextual information." - (let* ((name (org-element-property :drawer-name drawer)) - (output (if (functionp org-e-odt-format-drawer-function) - (funcall org-e-odt-format-drawer-function - name contents) - ;; If there's no user defined function: simply - ;; display contents of the drawer. - contents))) - (org-e-odt--wrap-label drawer output))) - - -;;;; Dynamic Block - -(defun org-e-odt-dynamic-block (dynamic-block contents info) - "Transcode a DYNAMIC-BLOCK element from Org to ODT. -CONTENTS holds the contents of the block. INFO is a plist -holding contextual information. See `org-export-data'." - (org-e-odt--wrap-label dynamic-block contents)) - - -;;;; Entity - -(defun org-e-odt-entity (entity contents info) - "Transcode an ENTITY object from Org to ODT. -CONTENTS are the definition itself. INFO is a plist holding -contextual information." - ;; (let ((ent (org-element-property :latex entity))) - ;; (if (org-element-property :latex-math-p entity) - ;; (format "$%s$" ent) - ;; ent)) - (org-element-property :utf-8 entity)) - - -;;;; Example Block - -(defun org-e-odt-example-block (example-block contents info) - "Transcode a EXAMPLE-BLOCK element from Org to ODT. -CONTENTS is nil. INFO is a plist holding contextual information." - (org-e-odt--wrap-label - example-block (org-e-odt-format-code example-block info))) - - -;;;; Export Snippet - -(defun org-e-odt-export-snippet (export-snippet contents info) - "Transcode a EXPORT-SNIPPET object from Org to ODT. -CONTENTS is nil. INFO is a plist holding contextual information." - (when (eq (org-export-snippet-backend export-snippet) 'e-odt) - (org-element-property :value export-snippet))) - - -;;;; Export Block - -(defun org-e-odt-export-block (export-block contents info) - "Transcode a EXPORT-BLOCK element from Org to ODT. -CONTENTS is nil. INFO is a plist holding contextual information." - (when (string= (org-element-property :type export-block) "ODT") - (org-remove-indentation (org-element-property :value export-block)))) - - -;;;; Fixed Width - -(defun org-e-odt-fixed-width (fixed-width contents info) - "Transcode a FIXED-WIDTH element from Org to ODT. -CONTENTS is nil. INFO is a plist holding contextual information." - (org-e-odt--wrap-label - fixed-width (org-e-odt-do-format-code - (org-element-property :value fixed-width)))) - - -;;;; Footnote Definition - -;; Footnote Definitions are ignored. - - -;;;; Footnote Reference - -(defun org-e-odt-footnote-reference (footnote-reference contents info) - "Transcode a FOOTNOTE-REFERENCE element from Org to ODT. -CONTENTS is nil. INFO is a plist holding contextual information." - (let ((--format-footnote-definition - (function - (lambda (n def) - (setq n (format "%d" n)) - (let ((id (concat "fn" n)) - (note-class "footnote") - (par-style "Footnote")) - (format - "<text:note text:id=\"%s\" text:note-class=\"%s\">%s</text:note>" - id note-class - (concat - (format "<text:note-citation>%s</text:note-citation>" n) - (format "<text:note-body>%s</text:note-body>" def))))))) - (--format-footnote-reference - (function - (lambda (n) - (setq n (format "%d" n)) - (let ((note-class "footnote") - (ref-format "text") - (ref-name (concat "fn" n))) - (format - "<text:span text:style-name=\"%s\">%s</text:span>" - "OrgSuperscript" - (format "<text:note-ref text:note-class=\"%s\" text:reference-format=\"%s\" text:ref-name=\"%s\">%s</text:note-ref>" - note-class ref-format ref-name n))))))) - (concat - ;; Insert separator between two footnotes in a row. - (let ((prev (org-export-get-previous-element footnote-reference info))) - (and (eq (org-element-type prev) 'footnote-reference) - (format "<text:span text:style-name=\"%s\">%s</text:span>" - "OrgSuperscript" ","))) - ;; Trancode footnote reference. - (let ((n (org-export-get-footnote-number footnote-reference info))) - (cond - ((not (org-export-footnote-first-reference-p footnote-reference info)) - (funcall --format-footnote-reference n)) - ;; Inline definitions are secondary strings. |