Merge branch 'maint'
[org-mode.git] / lisp / ob-tangle.el
blob7e25b2cd1bc56d26e112b536bf2928a96f93200a
1 ;;; ob-tangle.el --- extract source code from org-mode files
3 ;; Copyright (C) 2009-2012 Free Software Foundation, Inc.
5 ;; Author: Eric Schulte
6 ;; Keywords: literate programming, reproducible research
7 ;; Homepage: http://orgmode.org
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software: you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation, either version 3 of the License, or
14 ;; (at your option) any later version.
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
24 ;;; Commentary:
26 ;; Extract the code from source blocks out into raw source-code files.
28 ;;; Code:
29 (require 'ob)
30 (require 'org-src)
31 (eval-when-compile
32 (require 'cl))
34 (declare-function org-link-escape "org" (text &optional table))
35 (declare-function org-heading-components "org" ())
36 (declare-function org-back-to-heading "org" (invisible-ok))
37 (declare-function org-fill-template "org" (template alist))
38 (declare-function org-babel-update-block-body "org" (new-body))
39 (declare-function make-directory "files" (dir &optional parents))
41 (defcustom org-babel-tangle-lang-exts
42 '(("emacs-lisp" . "el"))
43 "Alist mapping languages to their file extensions.
44 The key is the language name, the value is the string that should
45 be inserted as the extension commonly used to identify files
46 written in this language. If no entry is found in this list,
47 then the name of the language is used."
48 :group 'org-babel-tangle
49 :version "24.1"
50 :type '(repeat
51 (cons
52 (string "Language name")
53 (string "File Extension"))))
55 (defcustom org-babel-post-tangle-hook nil
56 "Hook run in code files tangled by `org-babel-tangle'."
57 :group 'org-babel
58 :version "24.1"
59 :type 'hook)
61 (defcustom org-babel-pre-tangle-hook '(save-buffer)
62 "Hook run at the beginning of `org-babel-tangle'."
63 :group 'org-babel
64 :version "24.1"
65 :type 'hook)
67 (defcustom org-babel-tangle-body-hook nil
68 "Hook run over the contents of each code block body."
69 :group 'org-babel
70 :version "24.1"
71 :type 'hook)
73 (defcustom org-babel-tangle-comment-format-beg "[[%link][%source-name]]"
74 "Format of inserted comments in tangled code files.
75 The following format strings can be used to insert special
76 information into the output using `org-fill-template'.
77 %start-line --- the line number at the start of the code block
78 %file --------- the file from which the code block was tangled
79 %link --------- Org-mode style link to the code block
80 %source-name -- name of the code block
82 Whether or not comments are inserted during tangling is
83 controlled by the :comments header argument."
84 :group 'org-babel
85 :version "24.1"
86 :type 'string)
88 (defcustom org-babel-tangle-comment-format-end "%source-name ends here"
89 "Format of inserted comments in tangled code files.
90 The following format strings can be used to insert special
91 information into the output using `org-fill-template'.
92 %start-line --- the line number at the start of the code block
93 %file --------- the file from which the code block was tangled
94 %link --------- Org-mode style link to the code block
95 %source-name -- name of the code block
97 Whether or not comments are inserted during tangling is
98 controlled by the :comments header argument."
99 :group 'org-babel
100 :version "24.1"
101 :type 'string)
103 (defcustom org-babel-process-comment-text #'org-babel-trim
104 "Function called to process raw Org-mode text collected to be
105 inserted as comments in tangled source-code files. The function
106 should take a single string argument and return a string
107 result. The default value is `org-babel-trim'."
108 :group 'org-babel
109 :version "24.1"
110 :type 'function)
112 (defun org-babel-find-file-noselect-refresh (file)
113 "Find file ensuring that the latest changes on disk are
114 represented in the file."
115 (find-file-noselect file)
116 (with-current-buffer (get-file-buffer file)
117 (revert-buffer t t t)))
119 (defmacro org-babel-with-temp-filebuffer (file &rest body)
120 "Open FILE into a temporary buffer execute BODY there like
121 `progn', then kill the FILE buffer returning the result of
122 evaluating BODY."
123 (declare (indent 1))
124 (let ((temp-path (make-symbol "temp-path"))
125 (temp-result (make-symbol "temp-result"))
126 (temp-file (make-symbol "temp-file"))
127 (visited-p (make-symbol "visited-p")))
128 `(let* ((,temp-path ,file)
129 (,visited-p (get-file-buffer ,temp-path))
130 ,temp-result ,temp-file)
131 (org-babel-find-file-noselect-refresh ,temp-path)
132 (setf ,temp-file (get-file-buffer ,temp-path))
133 (with-current-buffer ,temp-file
134 (setf ,temp-result (progn ,@body)))
135 (unless ,visited-p (kill-buffer ,temp-file))
136 ,temp-result)))
137 (def-edebug-spec org-babel-with-temp-filebuffer (form body))
139 ;;;###autoload
140 (defun org-babel-load-file (file)
141 "Load Emacs Lisp source code blocks in the Org-mode FILE.
142 This function exports the source code using
143 `org-babel-tangle' and then loads the resulting file using
144 `load-file'."
145 (interactive "fFile to load: ")
146 (let* ((age (lambda (file)
147 (float-time
148 (time-subtract (current-time)
149 (nth 5 (or (file-attributes (file-truename file))
150 (file-attributes file)))))))
151 (base-name (file-name-sans-extension file))
152 (exported-file (concat base-name ".el")))
153 ;; tangle if the org-mode file is newer than the elisp file
154 (unless (and (file-exists-p exported-file)
155 (> (funcall age file) (funcall age exported-file)))
156 (org-babel-tangle-file file exported-file "emacs-lisp"))
157 (load-file exported-file)
158 (message "Loaded %s" exported-file)))
160 ;;;###autoload
161 (defun org-babel-tangle-file (file &optional target-file lang)
162 "Extract the bodies of source code blocks in FILE.
163 Source code blocks are extracted with `org-babel-tangle'.
164 Optional argument TARGET-FILE can be used to specify a default
165 export file for all source blocks. Optional argument LANG can be
166 used to limit the exported source code blocks by language."
167 (interactive "fFile to tangle: \nP")
168 (let ((visited-p (get-file-buffer (expand-file-name file)))
169 to-be-removed)
170 (save-window-excursion
171 (find-file file)
172 (setq to-be-removed (current-buffer))
173 (org-babel-tangle nil target-file lang))
174 (unless visited-p
175 (kill-buffer to-be-removed))))
177 (defun org-babel-tangle-publish (_ filename pub-dir)
178 "Tangle FILENAME and place the results in PUB-DIR."
179 (mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename)))
181 ;;;###autoload
182 (defun org-babel-tangle (&optional only-this-block target-file lang)
183 "Write code blocks to source-specific files.
184 Extract the bodies of all source code blocks from the current
185 file into their own source-specific files. Optional argument
186 TARGET-FILE can be used to specify a default export file for all
187 source blocks. Optional argument LANG can be used to limit the
188 exported source code blocks by language."
189 (interactive "P")
190 (run-hooks 'org-babel-pre-tangle-hook)
191 ;; possibly restrict the buffer to the current code block
192 (save-restriction
193 (when only-this-block
194 (unless (org-babel-where-is-src-block-head)
195 (error "Point is not currently inside of a code block"))
196 (save-match-data
197 (unless (or (cdr (assoc :tangle (nth 2 (org-babel-get-src-block-info))))
198 target-file)
199 (setq target-file
200 (read-from-minibuffer "Tangle to: " (buffer-file-name)))))
201 (narrow-to-region (match-beginning 0) (match-end 0)))
202 (save-excursion
203 (let ((block-counter 0)
204 (org-babel-default-header-args
205 (if target-file
206 (org-babel-merge-params org-babel-default-header-args
207 (list (cons :tangle target-file)))
208 org-babel-default-header-args))
209 path-collector)
210 (mapc ;; map over all languages
211 (lambda (by-lang)
212 (let* ((lang (car by-lang))
213 (specs (cdr by-lang))
214 (ext (or (cdr (assoc lang org-babel-tangle-lang-exts)) lang))
215 (lang-f (intern
216 (concat
217 (or (and (cdr (assoc lang org-src-lang-modes))
218 (symbol-name
219 (cdr (assoc lang org-src-lang-modes))))
220 lang)
221 "-mode")))
222 she-banged)
223 (mapc
224 (lambda (spec)
225 (let ((get-spec (lambda (name) (cdr (assoc name (nth 4 spec))))))
226 (let* ((tangle (funcall get-spec :tangle))
227 (she-bang ((lambda (sheb) (when (> (length sheb) 0) sheb))
228 (funcall get-spec :shebang)))
229 (base-name (cond
230 ((string= "yes" tangle)
231 (file-name-sans-extension
232 (buffer-file-name)))
233 ((string= "no" tangle) nil)
234 ((> (length tangle) 0) tangle)))
235 (file-name (when base-name
236 ;; decide if we want to add ext to base-name
237 (if (and ext (string= "yes" tangle))
238 (concat base-name "." ext) base-name))))
239 (when file-name
240 ;; possibly create the parent directories for file
241 (when ((lambda (m) (and m (not (string= m "no"))))
242 (funcall get-spec :mkdirp))
243 (make-directory (file-name-directory file-name) 'parents))
244 ;; delete any old versions of file
245 (when (and (file-exists-p file-name)
246 (not (member file-name path-collector)))
247 (delete-file file-name))
248 ;; drop source-block to file
249 (with-temp-buffer
250 (when (fboundp lang-f) (ignore-errors (funcall lang-f)))
251 (when (and she-bang (not (member file-name she-banged)))
252 (insert (concat she-bang "\n"))
253 (setq she-banged (cons file-name she-banged)))
254 (org-babel-spec-to-string spec)
255 ;; We avoid append-to-file as it does not work with tramp.
256 (let ((content (buffer-string)))
257 (with-temp-buffer
258 (if (file-exists-p file-name)
259 (insert-file-contents file-name))
260 (goto-char (point-max))
261 (insert content)
262 (write-region nil nil file-name))))
263 ;; if files contain she-bangs, then make the executable
264 (when she-bang (set-file-modes file-name #o755))
265 ;; update counter
266 (setq block-counter (+ 1 block-counter))
267 (add-to-list 'path-collector file-name)))))
268 specs)))
269 (org-babel-tangle-collect-blocks lang))
270 (message "Tangled %d code block%s from %s" block-counter
271 (if (= block-counter 1) "" "s")
272 (file-name-nondirectory
273 (buffer-file-name (or (buffer-base-buffer) (current-buffer)))))
274 ;; run `org-babel-post-tangle-hook' in all tangled files
275 (when org-babel-post-tangle-hook
276 (mapc
277 (lambda (file)
278 (org-babel-with-temp-filebuffer file
279 (run-hooks 'org-babel-post-tangle-hook)))
280 path-collector))
281 path-collector))))
283 (defun org-babel-tangle-clean ()
284 "Remove comments inserted by `org-babel-tangle'.
285 Call this function inside of a source-code file generated by
286 `org-babel-tangle' to remove all comments inserted automatically
287 by `org-babel-tangle'. Warning, this comment removes any lines
288 containing constructs which resemble org-mode file links or noweb
289 references."
290 (interactive)
291 (goto-char (point-min))
292 (while (or (re-search-forward "\\[\\[file:.*\\]\\[.*\\]\\]" nil t)
293 (re-search-forward (org-babel-noweb-wrap) nil t))
294 (delete-region (save-excursion (beginning-of-line 1) (point))
295 (save-excursion (end-of-line 1) (forward-char 1) (point)))))
297 (defvar org-stored-links)
298 (defvar org-bracket-link-regexp)
299 (defun org-babel-spec-to-string (spec)
300 "Insert SPEC into the current file.
301 Insert the source-code specified by SPEC into the current
302 source code file. This function uses `comment-region' which
303 assumes that the appropriate major-mode is set. SPEC has the
304 form
306 (start-line file link source-name params body comment)"
307 (let* ((start-line (nth 0 spec))
308 (file (nth 1 spec))
309 (link (nth 2 spec))
310 (source-name (nth 3 spec))
311 (body (nth 5 spec))
312 (comment (nth 6 spec))
313 (comments (cdr (assoc :comments (nth 4 spec))))
314 (padline (not (string= "no" (cdr (assoc :padline (nth 4 spec))))))
315 (link-p (or (string= comments "both") (string= comments "link")
316 (string= comments "yes") (string= comments "noweb")))
317 (link-data (mapcar (lambda (el)
318 (cons (symbol-name el)
319 ((lambda (le)
320 (if (stringp le) le (format "%S" le)))
321 (eval el))))
322 '(start-line file link source-name)))
323 (insert-comment (lambda (text)
324 (when (and comments (not (string= comments "no"))
325 (> (length text) 0))
326 (when padline (insert "\n"))
327 (comment-region (point) (progn (insert text) (point)))
328 (end-of-line nil) (insert "\n")))))
329 (when comment (funcall insert-comment comment))
330 (when link-p
331 (funcall
332 insert-comment
333 (org-fill-template org-babel-tangle-comment-format-beg link-data)))
334 (when padline (insert "\n"))
335 (insert
336 (format
337 "%s\n"
338 (replace-regexp-in-string
339 "^," ""
340 (org-babel-trim body (if org-src-preserve-indentation "[\f\n\r\v]")))))
341 (when link-p
342 (funcall
343 insert-comment
344 (org-fill-template org-babel-tangle-comment-format-end link-data)))))
346 (defun org-babel-tangle-collect-blocks (&optional language)
347 "Collect source blocks in the current Org-mode file.
348 Return an association list of source-code block specifications of
349 the form used by `org-babel-spec-to-string' grouped by language.
350 Optional argument LANG can be used to limit the collected source
351 code blocks by language."
352 (let ((block-counter 1) (current-heading "") blocks)
353 (org-babel-map-src-blocks (buffer-file-name)
354 ((lambda (new-heading)
355 (if (not (string= new-heading current-heading))
356 (progn
357 (setq block-counter 1)
358 (setq current-heading new-heading))
359 (setq block-counter (+ 1 block-counter))))
360 (replace-regexp-in-string "[ \t]" "-"
361 (condition-case nil
362 (or (nth 4 (org-heading-components))
363 "(dummy for heading without text)")
364 (error (buffer-file-name)))))
365 (let* ((start-line (save-restriction (widen)
366 (+ 1 (line-number-at-pos (point)))))
367 (file (buffer-file-name))
368 (info (org-babel-get-src-block-info 'light))
369 (src-lang (nth 0 info)))
370 (unless (string= (cdr (assoc :tangle (nth 2 info))) "no")
371 (unless (and language (not (string= language src-lang)))
372 (let* ((info (org-babel-get-src-block-info))
373 (params (nth 2 info))
374 (link ((lambda (link)
375 (and (string-match org-bracket-link-regexp link)
376 (match-string 1 link)))
377 (org-no-properties
378 (org-store-link nil))))
379 (source-name
380 (intern (or (nth 4 info)
381 (format "%s:%d"
382 current-heading block-counter))))
383 (expand-cmd
384 (intern (concat "org-babel-expand-body:" src-lang)))
385 (assignments-cmd
386 (intern (concat "org-babel-variable-assignments:" src-lang)))
387 (body
388 ((lambda (body) ;; run the tangle-body-hook
389 (with-temp-buffer
390 (insert body)
391 (run-hooks 'org-babel-tangle-body-hook)
392 (buffer-string)))
393 ((lambda (body) ;; expand the body in language specific manner
394 (if (assoc :no-expand params)
395 body
396 (if (fboundp expand-cmd)
397 (funcall expand-cmd body params)
398 (org-babel-expand-body:generic
399 body params
400 (and (fboundp assignments-cmd)
401 (funcall assignments-cmd params))))))
402 (if (org-babel-noweb-p params :tangle)
403 (org-babel-expand-noweb-references info)
404 (nth 1 info)))))
405 (comment
406 (when (or (string= "both" (cdr (assoc :comments params)))
407 (string= "org" (cdr (assoc :comments params))))
408 ;; from the previous heading or code-block end
409 (funcall
410 org-babel-process-comment-text
411 (buffer-substring
412 (max (condition-case nil
413 (save-excursion
414 (org-back-to-heading t) ; sets match data
415 (match-end 0))
416 (error (point-min)))
417 (save-excursion
418 (if (re-search-backward
419 org-babel-src-block-regexp nil t)
420 (match-end 0)
421 (point-min))))
422 (point)))))
423 by-lang)
424 ;; add the spec for this block to blocks under it's language
425 (setq by-lang (cdr (assoc src-lang blocks)))
426 (setq blocks (delq (assoc src-lang blocks) blocks))
427 (setq blocks (cons
428 (cons src-lang
429 (cons (list start-line file link
430 source-name params body comment)
431 by-lang)) blocks)))))))
432 ;; ensure blocks in the correct order
433 (setq blocks
434 (mapcar
435 (lambda (by-lang) (cons (car by-lang) (reverse (cdr by-lang))))
436 blocks))
437 blocks))
439 (defun org-babel-tangle-comment-links ( &optional info)
440 "Return a list of begin and end link comments for the code block at point."
441 (let* ((start-line (org-babel-where-is-src-block-head))
442 (file (buffer-file-name))
443 (link (org-link-escape (progn (call-interactively 'org-store-link)
444 (org-no-properties
445 (car (pop org-stored-links))))))
446 (source-name (nth 4 (or info (org-babel-get-src-block-info 'light))))
447 (link-data (mapcar (lambda (el)
448 (cons (symbol-name el)
449 ((lambda (le)
450 (if (stringp le) le (format "%S" le)))
451 (eval el))))
452 '(start-line file link source-name))))
453 (list (org-fill-template org-babel-tangle-comment-format-beg link-data)
454 (org-fill-template org-babel-tangle-comment-format-end link-data))))
456 ;; de-tangling functions
457 (defvar org-bracket-link-analytic-regexp)
458 (defun org-babel-detangle (&optional source-code-file)
459 "Propagate changes in source file back original to Org-mode file.
460 This requires that code blocks were tangled with link comments
461 which enable the original code blocks to be found."
462 (interactive)
463 (save-excursion
464 (when source-code-file (find-file source-code-file))
465 (goto-char (point-min))
466 (let ((counter 0) new-body end)
467 (while (re-search-forward org-bracket-link-analytic-regexp nil t)
468 (when (re-search-forward
469 (concat " " (regexp-quote (match-string 5)) " ends here"))
470 (setq end (match-end 0))
471 (forward-line -1)
472 (save-excursion
473 (when (setq new-body (org-babel-tangle-jump-to-org))
474 (org-babel-update-block-body new-body)))
475 (setq counter (+ 1 counter)))
476 (goto-char end))
477 (prog1 counter (message "Detangled %d code blocks" counter)))))
479 (defun org-babel-tangle-jump-to-org ()
480 "Jump from a tangled code file to the related Org-mode file."
481 (interactive)
482 (let ((mid (point))
483 start end done
484 target-buffer target-char link path block-name body)
485 (save-window-excursion
486 (save-excursion
487 (while (and (re-search-backward org-bracket-link-analytic-regexp nil t)
488 (not ; ever wider searches until matching block comments
489 (and (setq start (point-at-eol))
490 (setq link (match-string 0))
491 (setq path (match-string 3))
492 (setq block-name (match-string 5))
493 (save-excursion
494 (save-match-data
495 (re-search-forward
496 (concat " " (regexp-quote block-name)
497 " ends here") nil t)
498 (setq end (point-at-bol))))))))
499 (unless (and start (< start mid) (< mid end))
500 (error "Not in tangled code"))
501 (setq body (org-babel-trim (buffer-substring start end))))
502 (when (string-match "::" path)
503 (setq path (substring path 0 (match-beginning 0))))
504 (find-file path) (setq target-buffer (current-buffer))
505 (goto-char start) (org-open-link-from-string link)
506 (if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name)
507 (org-babel-next-src-block
508 (string-to-number (match-string 1 block-name)))
509 (org-babel-goto-named-src-block block-name))
510 (setq target-char (point)))
511 (pop-to-buffer target-buffer)
512 (prog1 body (goto-char target-char))))
514 (provide 'ob-tangle)
516 ;; Local variables:
517 ;; generated-autoload-file: "org-loaddefs.el"
518 ;; End:
520 ;;; ob-tangle.el ends here