Add org-eval-light.el and org-exp-blocks.el by Eric Schulte.

contrib/lisp/org-eval-light.el

@@ -0,0 +1,200 @@
+;;; org-eval-light.el --- Display result of evaluating code in various languages (light)
+
+;; Copyright (C) 2008 Free Software Foundation, Inc.
+
+;; Author: Carsten Dominik <carsten at orgmode dot org>,
+;;         Eric Schulte <schulte dot eric at gmail dot com>
+;; Keywords: outlines, hypermedia, calendar, wp, literate programming,
+;;           reproducible research
+;; Homepage: http://orgmode.org
+;; Version: 0.04
+
+;; This file is not yet part of GNU Emacs.
+
+;; GNU Emacs is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; This file is based off of org-eval, with the following changes.
+;;
+;; 1) forms are only executed manually, (allowing for the execution of
+;;    an entire subtree of forms)
+;; 2) use the org-mode style src blocks, rather than the muse style
+;;    <code></code> blocks
+;; 3) forms are not replaced by their outputs, but rather the output
+;;    is placed in the buffer immediately following the src block
+;;    commented by `org-eval-light-make-region-example' (when
+;;    evaluated with a prefix argument no output is placed in the
+;;    buffer)
+;; 4) add defadvice to org-ctrl-c-ctrl-c so that when called inside of
+;;    a source block it will call `org-eval-light-current-snippet'
+
+;;; Code:
+(require 'org)
+
+(defgroup org-eval-light nil
+  "Options concerning including output from commands into the Org-mode buffer."
+  :tag "Org Eval"
+  :group 'org)
+
+(defvar org-eval-light-example-size-cutoff 10
+  "The number of lines under which an example is considered
+'small', and is exported with the '^:' syntax instead of in a
+large example block")
+
+(defvar org-eval-light-regexp nil)
+
+(defun org-eval-light-set-interpreters (var value)
+  (set-default var value)
+  (setq org-eval-light-regexp
+	(concat "#\\+begin_src \\("
+		(mapconcat 'regexp-quote value "\\|")
+		"\\)\\([^\000]+?\\)#\\+end_src")))
+
+(defcustom org-eval-light-interpreters '("lisp" "emacs-lisp" "ruby" "shell-script")
+  "Interpreters allows for evaluation tags.
+This is a list of program names (as strings) that can evaluate code and
+insert the output into an Org-mode buffer.  Valid choices are 
+
+lisp    Interpret Emacs Lisp code and display the result
+shell   Pass command to the shell and display the result
+perl    The perl interpreter
+python  Thy python interpreter
+ruby    The ruby interpreter"
+  :group 'org-eval-light
+  :set 'org-eval-light-set-interpreters
+  :type '(set :greedy t
+	      (const "lisp")
+	      (const "emacs-lisp")
+	      (const "perl")
+	      (const "python")
+	      (const "ruby")
+	      (const "shell")))
+
+;;; functions
+(defun org-eval-light-inside-snippet ()
+  (interactive)
+  (save-excursion
+    (let ((case-fold-search t)
+	  (start-re "^#\\+begin_src\\( \\([^ \t\n]+\\)\\)?.*\n")
+	  (end-re "\n#\\+end_src")
+	  (pos (point))
+	  beg end)
+      (if (and (setq beg (re-search-backward start-re nil t))
+	       (setq end (re-search-forward end-re nil t))
+	       (<= beg pos) (>= end pos))
+	  t))))
+
+(defun org-eval-light-make-region-example (beg end)
+  "Comment out region using either the '^:' or the BEGIN_EXAMPLE
+syntax based on the size of the region as compared to
+`org-eval-light-example-size-cutoff'."
+  (interactive "*r")
+  (let ((size (abs (- (line-number-at-pos end)
+		      (line-number-at-pos beg)))))
+    (if (= size 0)
+	(let ((result (buffer-substring beg end)))
+	  (delete-region beg end)
+	  (insert (concat ": " result)))
+      (if (<= size org-eval-light-example-size-cutoff)
+	  (save-excursion
+	    (goto-char beg)
+	    (dotimes (n size)
+	      (move-beginning-of-line 1) (insert ": ") (forward-line 1)))
+	(let ((result (buffer-substring beg end)))
+	  (delete-region beg end)
+	  (insert (concat "#+BEGIN_EXAMPLE\n" result "#+END_EXAMPLE\n")))))))
+
+(defun org-eval-light-current-snippet (&optional arg)
+  "Execute the current #+begin_src #+end_src block, and dump the
+results into the buffer immediately following the src block,
+commented by `org-eval-light-make-region-example'."
+  (interactive "P")
+  (let ((line (org-current-line))
+	(case-fold-search t)
+	(info (org-edit-src-find-region-and-lang))
+	beg end lang result)
+    (setq beg (nth 0 info)
+	    end (nth 1 info)
+	    lang (nth 2 info))
+    (unless (member lang org-eval-light-interpreters)
+      (error "Language is not in `org-eval-light-interpreters': %s" lang))
+    (goto-line line)
+    (setq result (org-eval-light-code lang (buffer-substring beg end)))
+    (unless arg
+      (save-excursion
+      (re-search-forward "^#\\+end_src" nil t) (open-line 1) (forward-char 2)
+      (let ((beg (point))
+	    (end (progn (insert result)
+			(point))))
+	(message (format "from %S %S" beg end))
+	(org-eval-light-make-region-example beg end))))))
+
+(defun org-eval-light-eval-subtree (&optional arg)
+  "Replace EVAL snippets in the entire subtree."
+  (interactive "P")
+  (save-excursion
+    (org-narrow-to-subtree)
+    (goto-char (point-min))
+    (while (re-search-forward org-eval-light-regexp nil t)
+      (org-eval-light-current-snippet arg))
+    (widen)))
+
+(defun org-eval-light-code (interpreter code)
+  (cond
+   ((member interpreter '("lisp" "emacs-lisp"))
+    (org-eval-light-lisp (concat "(progn\n" code "\n)")))
+   ((equal interpreter "shell")
+    (shell-command-to-string code))
+   ((member interpreter '("perl" "python" "ruby"))
+    (org-eval-light-run (executable-find interpreter) code))
+   (t (error "Cannot evaluate code type %s" interpreter))))
+
+(defun org-eval-light-lisp (form)
+  "Evaluate the given form and return the result as a string."
+  (require 'pp)
+  (save-match-data
+    (condition-case err
+        (let ((object (eval (read form))))
+          (cond
+           ((stringp object) object)
+           ((and (listp object)
+                 (not (eq object nil)))
+            (let ((string (pp-to-string object)))
+              (substring string 0 (1- (length string)))))
+           ((numberp object)
+            (number-to-string object))
+           ((eq object nil) "")
+           (t
+            (pp-to-string object))))
+      (error
+       (org-display-warning (format "%s: Error evaluating %s: %s"
+                                     "???" form err))
+       "; INVALID LISP CODE"))))
+
+(defun org-eval-light-run (cmd code)
+  (with-temp-buffer
+    (insert code)
+    (shell-command-on-region (point-min) (point-max) cmd nil 'replace)
+    (buffer-string)))  
+
+(defadvice org-ctrl-c-ctrl-c (around org-cc-eval-source activate)
+  (if (org-eval-light-inside-snippet)
+      (call-interactively 'org-eval-light-current-snippet)
+    ad-do-it))
+
+(provide 'org-eval-light)
+;;; org-eval-light.el ends here

contrib/lisp/org-exp-blocks.el

@@ -0,0 +1,378 @@
+;;; org-exp-blocks.el --- pre-process blocks when exporting org files
+
+;; Copyright (C) 2008 Eric Schulte
+
+;; Author: Eric Schulte
+
+;; This file is not currently part of GNU Emacs.
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2, or (at
+;; your option) any later version.
+
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program ; see the file COPYING.  If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
+;;
+;; This is a utility for pre-processing blocks in org files before
+;; export using the `org-export-preprocess-hook'.  It can be used for
+;; exporting new types of blocks from org-mode files and also for
+;; changing the default export behavior of existing org-mode blocks.
+;; The `org-export-blocks' and `org-export-interblocks' alist can be
+;; used to control how blocks and the spaces between blocks
+;; respectively are processed upon export.
+;;
+;; The type of a block is defined as the string following =#+begin_=,
+;; so for example the following block would be of type ditaa.  Note
+;; that both upper or lower case are allowed in =#+BEGIN_= and
+;; =#+END_=.
+;;
+;; #+begin_ditaa blue.png -r -S
+;; +---------+
+;; | cBLU    |
+;; |         |
+;; |    +----+
+;; |    |cPNK|
+;; |    |    |
+;; +----+----+
+;; #+end_ditaa
+;;
+;;; Currently Implemented Block Types
+;;
+;; ditaa :: Convert ascii pictures to actual images using ditaa
+;;          http://ditaa.sourceforge.net/.  To use this set
+;;          `org-ditaa-jar-path' to the path to ditaa.jar on your
+;;          system (should be set automatically in most cases) .
+;;
+;; dot :: Convert graphs defined using the dot graphing language to
+;;        images using the dot utility.  For information on dot see
+;;        http://www.graphviz.org/
+;;
+;; comment :: Wrap comments with titles and author information, in
+;;            their own divs with author-specific ids allowing for css
+;;            coloring of comments based on the author.
+;;
+;; R :: Implements Sweave type exporting, evaluates blocks of R code,
+;;      and also replaces \R{} chunks in the file with their result
+;;      when passed to R.  This require the `R' command which is
+;;      provided by ESS (Emacs Speaks Statistics).
+
+(defcustom org-export-blocks
+  '((comment org-export-blocks-format-comment)
+    (ditaa org-export-blocks-format-ditaa)
+    (dot org-export-blocks-format-dot)
+    (r org-export-blocks-format-R)
+    (R org-export-blocks-format-R))
+  "Use this a-list to associate block types with block exporting
+functions.  The type of a block is determined by the text
+immediately following the '#+BEGIN_' portion of the block header.
+Each block export function should accept three argumets..."
+  :group 'org-export-general
+  :type 'alist)
+
+(defcustom org-export-interblocks
+  '((r org-export-interblocks-format-R)
+    (R org-export-interblocks-format-R))
+  "Use this a-list to associate block types with block exporting
+functions.  The type of a block is determined by the text
+immediately following the '#+BEGIN_' portion of the block header.
+Each block export function should accept three argumets..."
+  :group 'org-export-general
+  :type 'alist)
+
+(defcustom org-export-blocks-witheld
+  '(hidden)
+  "List of block types (see `org-export-blocks') which should not
+be exported."
+  :group 'org-export-general
+  :type 'list)
+
+(defvar org-export-blocks-postblock-hooks nil "")
+
+(defun org-export-blocks-html-quote (body &optional open close)
+  "Protext BODY from org html export.  The optional OPEN and
+CLOSE tags will be inserted around BODY."
+  (concat
+   "\n#+BEGIN_HTML\n"
+   (or open "")
+   body (if (string-match "\n$" body) "" "\n")
+   (or close "")
+   "#+END_HTML\n"))
+
+(defun org-export-blocks-latex-quote (body &optional open close)
+  "Protext BODY from org latex export.  The optional OPEN and
+CLOSE tags will be inserted around BODY."
+  (concat
+   "\n#+BEGIN_LaTeX\n"
+   (or open "")
+   body (if (string-match "\n$" body) "" "\n")
+   (or close "")
+   "#+END_LaTeX\n"))
+
+(defun org-export-blocks-preprocess ()
+  "Export all blocks acording to the `org-export-blocks' block
+exportation alist.  Does not export block types specified in
+specified in BLOCKS which default to the value of
+`org-export-blocks-witheld'."
+  (interactive)
+  (save-window-excursion
+    (let ((count 0)
+	  (blocks org-export-blocks-witheld)
+	  (case-fold-search t)
+	  (types '())
+	  type func start end)
+      (flet ((interblock (start end type)
+			 (save-match-data
+			   (when (setf func (cadr (assoc type org-export-interblocks)))
+			     (funcall func start end)))))
+	(goto-char (point-min))
+	(setf start (point))
+	(while (re-search-forward
+		"^#\\+begin_\\(\\S-+\\)[ \t]*\\(.*\\)?[\r\n]\\([^\000]*?\\)#\\+end_\\S-*[\r\n]" nil t)
+	  (save-match-data (setf type (intern (match-string 1))))
+	  (unless (memq type types) (setf types (cons type types)))
+	  (setf end (save-match-data (match-beginning 0)))
+	  (interblock start end type)
+	  (if (setf func (cadr (assoc type org-export-blocks)))
+	      (replace-match (save-match-data
+			       (if (memq type blocks)
+				   ""
+				 (apply func (match-string 3) (split-string (match-string 2) " ")))) t t))
+	  (setf start (save-match-data (match-end 0))))
+	(mapcar (lambda (type)
+		  (interblock start (point-max) type))
+		types)))))
+
+(add-hook 'org-export-preprocess-hook 'org-export-blocks-preprocess)
+
+;;================================================================================
+;; type specific functions
+
+;;--------------------------------------------------------------------------------
+;; ditaa: create images from ASCII art using the ditaa utility
+(defvar org-ditaa-jar-path (expand-file-name
+			"ditaa.jar"
+			(file-name-as-directory
+			 (expand-file-name
+			  "scripts"
+			  (file-name-as-directory
+			   (expand-file-name
+			    ".."
+			    (file-name-directory (or load-file-name buffer-file-name)))))))
+  "Path to the ditaa jar executable")
+
+(defun org-export-blocks-format-ditaa (body &rest headers)
+  "Pass block BODY to the ditaa utility creating an image.
+Specify the path at which the image should be saved as the first
+element of headers, any additional elements of headers will be
+passed to the ditaa utility as command line arguments."
+  (message "ditaa-formatting...")
+  (let ((out-file (if headers (car headers)))
+	(args (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))
+	(data-file (make-temp-file "org-ditaa")))
+    (unless (file-exists-p org-ditaa-jar-path)
+      (error (format "Could not find ditaa.jar at %s" org-ditaa-jar-path)))
+    (setq body (if (string-match "^\\([^:\\|:[^ ]\\)" body)
+		   body
+		 (mapconcat (lambda (x) (substring x 2))
+			    (org-split-string body "\n")
+			    "\n")))
+    (cond 
+     ((or htmlp latexp)
+      (with-temp-file data-file (insert body))
+      (message (concat "java -jar " org-ditaa-jar-path " " args " " data-file " " out-file))
+      (shell-command (concat "java -jar " org-ditaa-jar-path " " args " " data-file " " out-file))
+      (format "\n[[file:%s]]\n" out-file))
+     (t (concat
+	 "\n#+BEGIN_EXAMPLE\n"
+	 body (if (string-match "\n$" body) "" "\n")
+	 "#+END_EXAMPLE\n")))))
+
+;;--------------------------------------------------------------------------------
+;; dot: create graphs using the dot graphing language
+;;      (require the dot executable to be in your path)
+(defun org-export-blocks-format-dot (body &rest headers)
+  "Pass block BODY to the dot graphing utility creating an image.
+Specify the path at which the image should be saved as the first
+element of headers, any additional elements of headers will be
+passed to the dot utility as command line arguments.  Don't
+forget to specify the output type for the dot command, so if you
+are exporting to a file with a name like 'image.png' you should
+include a '-Tpng' argument, and your block should look like the
+following.
+
+#+begin_dot models.png -Tpng
+digraph data_relationships {
+  \"data_requirement\" [shape=Mrecord, label=\"{DataRequirement|description\lformat\l}\"]
+  \"data_product\" [shape=Mrecord, label=\"{DataProduct|name\lversion\lpoc\lformat\l}\"]
+  \"data_requirement\" -> \"data_product\"
+}
+#+end_dot"
+  (message "dot-formatting...")
+  (let ((out-file (if headers (car headers)))
+	(args (if (cdr headers) (mapconcat 'identity (cdr headers) " ")))
+	(data-file (make-temp-file "org-ditaa")))
+    (cond 
+     ((or htmlp latexp)
+      (with-temp-file data-file (insert body))
+      (message (concat "dot " data-file " " args " -o " out-file))
+      (shell-command (concat "dot " data-file " " args " -o " out-file))
+      (format "\n[[file:%s]]\n" out-file))
+     (t (concat
+	 "\n#+BEGIN_EXAMPLE\n"
+	 body (if (string-match "\n$" body) "" "\n")
+	 "#+END_EXAMPLE\n")))))
+
+;;--------------------------------------------------------------------------------
+;; comment: export comments in author-specific css-stylable divs
+(defun org-export-blocks-format-comment (body &rest headers)
+  "Format comment BODY by OWNER and return it formatted for export.
+Currently, this only does something for HTML export, for all
+other backends, it converts the comment into an EXAMPLE segment."
+  (let ((owner (if headers (car headers)))
+	(title (if (cdr headers) (mapconcat 'identity (cdr headers) " "))))
+    (cond
+     (htmlp ;; We are exporting to HTML
+      (concat "#+BEGIN_HTML\n"
+	      "<div class=\"org-comment\""
+	      (if owner (format " id=\"org-comment-%s\" " owner))
+	      ">\n"
+	      (if owner (concat "<b>" owner "</b> ") "")
+	      (if (and title (> (length title) 0)) (concat " -- " title "</br>\n") "</br>\n")
+	      "<p>\n"
+	      "#+END_HTML\n"
+	      body
+	      "#+BEGIN_HTML\n"
+	      "</p>\n"
+	      "</div>\n"
+	      "#+END_HTML\n"))
+     (t ;; This is not HTML, so just make it an example.
+      (concat "#+BEGIN_EXAMPLE\n"
+	      (if title (concat "Title:" title "\n") "")
+	      (if owner (concat "By:" owner "\n") "")
+	      body
+	      (if (string-match "\n\\'" body) "" "\n")
+	      "#+END_EXAMPLE\n")))))
+
+;;--------------------------------------------------------------------------------
+;; R: Sweave-type functionality
+(defvar interblock-R-buffer nil
+  "Holds the buffer for the current R process")
+
+(defun org-export-blocks-format-R (body &rest headers)
+  "Process R blocks and replace \R{} forms outside the blocks
+with their values as determined by R."
+  (interactive)
+  (message "R processing...")
+  (let ((image-path (or (and (car headers)
+			     (string-match "\\(.?\\)\.\\(EPS\\|eps\\)" (car headers))
+			     (match-string 1 (car headers)))
+			(and (> (length (car headers)) 0)
+			     (car headers))
+			;; create the default filename
+			(format "Rplot-%03d" count)))
+	(plot (string-match "plot" body))
+	R-proc)
+    (setf count (+ count 1))
+    (interblock-initiate-R-buffer)
+    (setf R-proc (get-buffer-process interblock-R-buffer))
+    ;; send strings to the ESS process using `comint-send-string'
+    (setf body (mapconcat (lambda (line)
+			    (interblock-R-input-command line) (concat "> " line))
+			  (butlast (split-string body "[\r\n]"))
+			  "\n"))
+    ;; if there is a plot command, then create the images
+    (when plot
+      (interblock-R-input-command (format "dev.copy2eps(file=\"%s.eps\")" image-path)))
+    (concat (cond
+	     (htmlp (org-export-blocks-html-quote body
+						  (format "<div id=\"R-%d\">\n<pre>\n" count)
+						  "</pre>\n</div>\n"))
+	     (latexp (org-export-blocks-latex-quote body
+						    "\\begin{Schunk}\n\\begin{Sinput}\n"
+						    "\\end{Sinput}\n\\end{Schunk}\n"))
+	     (t (insert ;; default export
+		 "#+begin_R " (mapconcat 'identity headers " ") "\n"
+		 body (if (string-match "\n$" body) "" "\n")
+		 "#+end_R\n")))
+	    (if plot
+		(format "[[file:%s.eps]]\n" image-path)
+	      ""))))
+
+(defun org-export-interblocks-format-R (start end)
+  "This is run over parts of the org-file which are between R
+blocks.  It's main use is to expand the \R{stuff} chunks for
+export."
+  (save-excursion
+    (goto-char start)
+    (interblock-initiate-R-buffer)
+    (let (code replacement)
+      (while (and (< (point) end) (re-search-forward "\\\\R{\\(.*\\)}" end t))
+	(save-match-data (setf code (match-string 1)))
+	(setf replacement (interblock-R-command-to-string code))
+	(setf replacement (cond
+			   (htmlp replacement)
+			   (latexp replacement)
+			   (t replacement)))
+	(setf end (+ end (- (length replacement) (length code))))
+	(replace-match replacement t t)))))
+
+(defun interblock-initiate-R-buffer ()
+  "If there is not a current R process then create one."
+  (unless (and (buffer-live-p interblock-R-buffer) (get-buffer interblock-R-buffer))
+    (save-excursion
+      (R)
+      (setf interblock-R-buffer (current-buffer))
+      (interblock-R-wait-for-output)
+      (interblock-R-input-command ""))))
+
+(defun interblock-R-command-to-string (command)
+  "Send a command to R, and return the results as a string."
+  (interblock-R-input-command command)
+  (interblock-R-last-output))
+
+(defun interblock-R-input-command (command)
+  "Pass COMMAND to the R process running in `interblock-R-buffer'."
+  (save-excursion
+    (save-match-data
+      (set-buffer interblock-R-buffer)
+      (goto-char (process-mark (get-buffer-process (current-buffer))))
+      (insert command)
+      (comint-send-input)
+      (interblock-R-wait-for-output))))
+
+(defun interblock-R-wait-for-output ()
+  "Wait until output arrives"
+  (save-excursion
+    (save-match-data
+      (set-buffer interblock-R-buffer)
+      (while (progn
+	       (goto-char comint-last-input-end)
+	       (not (re-search-forward comint-prompt-regexp nil t)))
+	(accept-process-output (get-buffer-process (current-buffer)))))))
+
+(defun interblock-R-last-output ()
+  "Return the last R output as a string"
+  (save-excursion
+    (save-match-data
+      (set-buffer interblock-R-buffer)
+      (goto-char (process-mark (get-buffer-process (current-buffer))))
+      (forward-line 0)
+      (let ((raw (buffer-substring comint-last-input-end (- (point) 1))))
+	(if (string-match "\n" raw)
+	    raw
+	  (and (string-match "\\[[[:digit:]+]\\] *\\(.*\\)$" raw)
+	       (message raw)
+	       (message (match-string 1 raw))
+	       (match-string 1 raw)))))))
+
+;;; org-exp-blocks.el ends here