lisp/babel/ob-tangle.el

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