lisp/ob-tangle.el

   1 ;;; ob-tangle.el --- extract source code from org-mode files
   2
   3 ;; Copyright (C) 2009, 2010  Free Software Foundation, Inc.
   4
   5 ;; Author: Eric Schulte
   6 ;; Keywords: literate programming, reproducible research
   7 ;; Homepage: http://orgmode.org
   8 ;; Version: 0.01
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; Extract the code from source blocks out into raw source-code files.
  28
  29 ;;; Code:
  30 (require 'ob)
  31 (require 'org-src)
  32 (eval-when-compile
  33   (require 'cl))
  34
  35 (declare-function org-link-escape "org" (text &optional table))
  36
  37 (defcustom org-babel-tangle-lang-exts
  38   '(("emacs-lisp" . "el"))
  39   "Alist mapping languages to their file extensions.
  40 The key is the language name, the value is the string that should
  41 be inserted as the extension commonly used to identify files
  42 written in this language.  If no entry is found in this list,
  43 then the name of the language is used."
  44   :group 'org-babel-tangle
  45   :type '(repeat
  46           (cons
  47            (string "Language name")
  48            (string "File Extension"))))
  49
  50 ;;;###autoload
  51 (defun org-babel-load-file (file)
  52   "Load the contents of the Emacs Lisp source code blocks in the
  53 org-mode formatted FILE.  This function will first export the
  54 source code using `org-babel-tangle' and then load the resulting
  55 file using `load-file'."
  56   (flet ((age (file)
  57               (float-time
  58                (time-subtract (current-time)
  59                               (nth 5 (or (file-attributes (file-truename file))
  60                                          (file-attributes file)))))))
  61     (let* ((base-name (file-name-sans-extension file))
  62            (exported-file (concat base-name ".el")))
  63       ;; tangle if the org-mode file is newer than the elisp file
  64       (unless (and (file-exists-p exported-file)
  65                    (> (age file) (age exported-file)))
  66         (org-babel-tangle-file file exported-file "emacs-lisp"))
  67       (load-file exported-file)
  68       (message "loaded %s" exported-file))))
  69
  70 ;;;###autoload
  71 (defun org-babel-tangle-file (file &optional target-file lang)
  72   "Extract the bodies of all source code blocks in FILE with
  73 `org-babel-tangle'.  Optional argument TARGET-FILE can be used to
  74 specify a default export file for all source blocks.  Optional
  75 argument LANG can be used to limit the exported source code
  76 blocks by language."
  77   (interactive "fFile to tangle: \nP")
  78   (let ((visited-p (get-file-buffer (expand-file-name file)))
  79         to-be-removed)
  80     (save-window-excursion
  81       (find-file file)
  82       (setq to-be-removed (current-buffer))
  83       (org-babel-tangle target-file lang))
  84     (unless visited-p
  85       (kill-buffer to-be-removed))))
  86
  87 (defun org-babel-tangle-publish (_ filename pub-dir)
  88   "Tangle FILENAME and place the results in PUB-DIR."
  89   (mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename)))
  90
  91 ;;;###autoload
  92 (defun org-babel-tangle (&optional target-file lang)
  93   "Extract the bodies of all source code blocks from the current
  94 file into their own source-specific files.  Optional argument
  95 TARGET-FILE can be used to specify a default export file for all
  96 source blocks.  Optional argument LANG can be used to limit the
  97 exported source code blocks by language."
  98   (interactive)
  99   (save-buffer)
 100   (save-excursion
 101     (let ((block-counter 0)
 102           path-collector)
 103       (mapc ;; map over all languages
 104        (lambda (by-lang)
 105          (let* ((lang (car by-lang))
 106                 (specs (cdr by-lang))
 107                 (ext (or (cdr (assoc lang org-babel-tangle-lang-exts)) lang))
 108                 (lang-f (intern
 109                          (concat
 110                           (or (and (cdr (assoc lang org-src-lang-modes))
 111                                    (symbol-name
 112                                     (cdr (assoc lang org-src-lang-modes))))
 113                               lang)
 114                           "-mode")))
 115                 she-banged)
 116            (mapc
 117             (lambda (spec)
 118               (flet ((get-spec (name)
 119                                (cdr (assoc name (nth 2 spec)))))
 120                 (let* ((tangle (get-spec :tangle))
 121                        (she-bang ((lambda (sheb) (when (> (length sheb) 0) sheb))
 122                                   (get-spec :shebang)))
 123                        (base-name (or (cond
 124                                        ((string= "yes" tangle)
 125                                         (file-name-sans-extension
 126                                          (buffer-file-name)))
 127                                        ((string= "no" tangle) nil)
 128                                        ((> (length tangle) 0) tangle))
 129                                       target-file))
 130                        (file-name (when base-name
 131                                     ;; decide if we want to add ext to base-name
 132                                     (if (and ext (string= "yes" tangle))
 133                                         (concat base-name "." ext) base-name))))
 134                   (when file-name
 135                     ;; delete any old versions of file
 136                     (when (and (file-exists-p file-name)
 137                                (not (member file-name path-collector)))
 138                       (delete-file file-name))
 139                     ;; drop source-block to file
 140                     (with-temp-buffer
 141                       (if (fboundp lang-f) (funcall lang-f))
 142                       (when (and she-bang (not (member file-name she-banged)))
 143                         (insert (concat she-bang "\n"))
 144                         (setq she-banged (cons file-name she-banged)))
 145                       (org-babel-spec-to-string spec)
 146                       ;; We avoid append-to-file as it does not work with tramp.
 147                       (let ((content (buffer-string)))
 148                         (with-temp-buffer
 149                           (if (file-exists-p file-name)
 150                               (insert-file-contents file-name))
 151                           (goto-char (point-max))
 152                           (insert content)
 153                           (write-region nil nil file-name))))
 154                     ;; if files contain she-bangs, then make the executable
 155                     (when she-bang (set-file-modes file-name ?\755))
 156                     ;; update counter
 157                     (setq block-counter (+ 1 block-counter))
 158                     (add-to-list 'path-collector file-name)))))
 159             specs)))
 160        (org-babel-tangle-collect-blocks lang))
 161       (message "tangled %d code block%s" block-counter
 162                (if (= block-counter 1) "" "s"))
 163       path-collector)))
 164
 165 (defun org-babel-tangle-clean ()
 166   "Call this function inside of a source-code file generated by
 167 `org-babel-tangle' to remove all comments inserted automatically
 168 by `org-babel-tangle'.  Warning, this comment removes any lines
 169 containing constructs which resemble org-mode file links or noweb
 170 references."
 171   (interactive)
 172   (goto-char (point-min))
 173   (while (or (re-search-forward "\\[\\[file:.*\\]\\[.*\\]\\]" nil t)
 174              (re-search-forward "<<[^[:space:]]*>>" nil t))
 175     (delete-region (save-excursion (beginning-of-line 1) (point))
 176                    (save-excursion (end-of-line 1) (forward-char 1) (point)))))
 177
 178 (defvar org-stored-links)
 179 (defun org-babel-tangle-collect-blocks (&optional lang)
 180   "Collect all source blocks in the current org-mode file.
 181 Return an association list of source-code block specifications of
 182 the form used by `org-babel-spec-to-string' grouped by language.
 183 Optional argument LANG can be used to limit the collected source
 184 code blocks by language."
 185   (let ((block-counter 0) blocks)
 186     (org-babel-map-source-blocks (buffer-file-name)
 187       (setq block-counter (+ 1 block-counter))
 188       (let* ((link (progn (call-interactively 'org-store-link)
 189                           (org-babel-clean-text-properties
 190                            (car (pop org-stored-links)))))
 191              (info (org-babel-get-src-block-info))
 192              (source-name (intern (or (nth 4 info)
 193                                       (format "block-%d" block-counter))))
 194              (src-lang (nth 0 info))
 195              (expand-cmd (intern (concat "org-babel-expand-body:" src-lang)))
 196              (params (nth 2 info))
 197              by-lang)
 198         (unless (string= (cdr (assoc :tangle params)) "no") ;; skip
 199           (unless (and lang (not (string= lang src-lang))) ;; limit by language
 200             ;; add the spec for this block to blocks under it's language
 201             (setq by-lang (cdr (assoc src-lang blocks)))
 202             (setq blocks (delq (assoc src-lang blocks) blocks))
 203             (setq blocks
 204                   (cons
 205                    (cons src-lang
 206                          (cons (list link source-name params
 207                                      ((lambda (body)
 208                                         (if (assoc :no-expand params)
 209                                             body
 210                                           (funcall
 211                                            (if (fboundp expand-cmd)
 212                                                expand-cmd
 213                                              'org-babel-expand-body:generic)
 214                                            body
 215                                            params)))
 216                                       (if (and (cdr (assoc :noweb params))
 217                                                (string=
 218                                                 "yes"
 219                                                 (cdr (assoc :noweb params))))
 220                                           (org-babel-expand-noweb-references
 221                                            info)
 222                                         (nth 1 info))))
 223                                by-lang)) blocks))))))
 224     ;; ensure blocks in the correct order
 225     (setq blocks
 226           (mapcar
 227            (lambda (by-lang) (cons (car by-lang) (reverse (cdr by-lang))))
 228            blocks))
 229     blocks))
 230
 231 (defun org-babel-spec-to-string (spec)
 232   "Insert the source-code specified by SPEC into the current
 233 source code file.  This function uses `comment-region' which
 234 assumes that the appropriate major-mode is set.  SPEC has the
 235 form
 236
 237   (link source-name params body)"
 238   (let ((link (nth 0 spec))
 239         (source-name (nth 1 spec))
 240         (body (nth 3 spec))
 241         (commentable (string= (cdr (assoc :comments (nth 2 spec))) "yes")))
 242     (flet ((insert-comment (text)
 243                            (when commentable
 244                              (insert "\n")
 245                              (comment-region (point)
 246                                              (progn (insert text) (point)))
 247                              (end-of-line nil)
 248                              (insert "\n"))))
 249       (insert-comment (format "[[%s][%s]]" (org-link-escape link) source-name))
 250       (insert (format "\n%s\n" (replace-regexp-in-string
 251                                 "^," "" (org-babel-chomp body))))
 252       (insert-comment (format "%s ends here" source-name)))))
 253
 254 (provide 'ob-tangle)
 255
 256 ;; arch-tag: 413ced93-48f5-4216-86e4-3fc5df8c8f24
 257
 258 ;;; ob-tangle.el ends here