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