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