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