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