Commit | Line | Data |
---|---|---|
86fbb8ca CD |
1 | ;;; ob-tangle.el --- extract source code from org-mode files |
2 | ||
73b0cd50 | 3 | ;; Copyright (C) 2009-2011 Free Software Foundation, Inc. |
86fbb8ca CD |
4 | |
5 | ;; Author: Eric Schulte | |
6 | ;; Keywords: literate programming, reproducible research | |
7 | ;; Homepage: http://orgmode.org | |
acedf35c | 8 | ;; Version: 7.4 |
86fbb8ca CD |
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" ()) | |
afe98dfa CD |
37 | (declare-function org-back-to-heading "org" (invisible-ok)) |
38 | (declare-function org-fill-template "org" (template alist)) | |
39 | (declare-function org-babel-update-block-body "org" (new-body)) | |
86fbb8ca | 40 | |
afe98dfa | 41 | ;;;###autoload |
86fbb8ca CD |
42 | (defcustom org-babel-tangle-lang-exts |
43 | '(("emacs-lisp" . "el")) | |
44 | "Alist mapping languages to their file extensions. | |
45 | The key is the language name, the value is the string that should | |
46 | be inserted as the extension commonly used to identify files | |
47 | written in this language. If no entry is found in this list, | |
48 | then the name of the language is used." | |
49 | :group 'org-babel-tangle | |
50 | :type '(repeat | |
51 | (cons | |
52 | (string "Language name") | |
53 | (string "File Extension")))) | |
54 | ||
55 | (defcustom org-babel-post-tangle-hook nil | |
56 | "Hook run in code files tangled by `org-babel-tangle'." | |
57 | :group 'org-babel | |
58 | :type 'hook) | |
59 | ||
afe98dfa CD |
60 | (defcustom org-babel-pre-tangle-hook '(save-buffer) |
61 | "Hook run at the beginning of `org-babel-tangle'." | |
62 | :group 'org-babel | |
63 | :type 'hook) | |
64 | ||
65 | (defcustom org-babel-tangle-pad-newline t | |
66 | "Switch indicating whether to pad tangled code with newlines." | |
67 | :group 'org-babel | |
68 | :type 'boolean) | |
69 | ||
70 | (defcustom org-babel-tangle-comment-format-beg "[[%link][%source-name]]" | |
71 | "Format of inserted comments in tangled code files. | |
72 | The following format strings can be used to insert special | |
73 | information into the output using `org-fill-template'. | |
74 | %start-line --- the line number at the start of the code block | |
75 | %file --------- the file from which the code block was tangled | |
76 | %link --------- Org-mode style link to the code block | |
77 | %source-name -- name of the code block | |
78 | ||
79 | Whether or not comments are inserted during tangling is | |
80 | controlled by the :comments header argument." | |
81 | :group 'org-babel | |
82 | :type 'string) | |
83 | ||
84 | (defcustom org-babel-tangle-comment-format-end "%source-name ends here" | |
85 | "Format of inserted comments in tangled code files. | |
86 | The following format strings can be used to insert special | |
87 | information into the output using `org-fill-template'. | |
88 | %start-line --- the line number at the start of the code block | |
89 | %file --------- the file from which the code block was tangled | |
90 | %link --------- Org-mode style link to the code block | |
91 | %source-name -- name of the code block | |
92 | ||
93 | Whether or not comments are inserted during tangling is | |
94 | controlled by the :comments header argument." | |
95 | :group 'org-babel | |
96 | :type 'string) | |
97 | ||
98 | (defun org-babel-find-file-noselect-refresh (file) | |
99 | "Find file ensuring that the latest changes on disk are | |
100 | represented in the file." | |
101 | (find-file-noselect file) | |
102 | (with-current-buffer (get-file-buffer file) | |
103 | (revert-buffer t t t))) | |
104 | ||
86fbb8ca CD |
105 | (defmacro org-babel-with-temp-filebuffer (file &rest body) |
106 | "Open FILE into a temporary buffer execute BODY there like | |
107 | `progn', then kill the FILE buffer returning the result of | |
108 | evaluating BODY." | |
109 | (declare (indent 1)) | |
110 | (let ((temp-result (make-symbol "temp-result")) | |
afe98dfa CD |
111 | (temp-file (make-symbol "temp-file")) |
112 | (visited-p (make-symbol "visited-p"))) | |
113 | `(let (,temp-result ,temp-file | |
114 | (,visited-p (get-file-buffer ,file))) | |
115 | (org-babel-find-file-noselect-refresh ,file) | |
116 | (setf ,temp-file (get-file-buffer ,file)) | |
117 | (with-current-buffer ,temp-file | |
118 | (setf ,temp-result (progn ,@body))) | |
119 | (unless ,visited-p (kill-buffer ,temp-file)) | |
86fbb8ca CD |
120 | ,temp-result))) |
121 | ||
122 | ;;;###autoload | |
123 | (defun org-babel-load-file (file) | |
124 | "Load Emacs Lisp source code blocks in the Org-mode FILE. | |
125 | This function exports the source code using | |
126 | `org-babel-tangle' and then loads the resulting file using | |
127 | `load-file'." | |
acedf35c | 128 | (interactive "fFile to load: ") |
86fbb8ca CD |
129 | (flet ((age (file) |
130 | (float-time | |
131 | (time-subtract (current-time) | |
132 | (nth 5 (or (file-attributes (file-truename file)) | |
133 | (file-attributes file))))))) | |
134 | (let* ((base-name (file-name-sans-extension file)) | |
135 | (exported-file (concat base-name ".el"))) | |
136 | ;; tangle if the org-mode file is newer than the elisp file | |
137 | (unless (and (file-exists-p exported-file) | |
138 | (> (age file) (age exported-file))) | |
139 | (org-babel-tangle-file file exported-file "emacs-lisp")) | |
140 | (load-file exported-file) | |
141 | (message "loaded %s" exported-file)))) | |
142 | ||
143 | ;;;###autoload | |
144 | (defun org-babel-tangle-file (file &optional target-file lang) | |
145 | "Extract the bodies of source code blocks in FILE. | |
146 | Source code blocks are extracted with `org-babel-tangle'. | |
147 | Optional argument TARGET-FILE can be used to specify a default | |
148 | export file for all source blocks. Optional argument LANG can be | |
149 | used to limit the exported source code blocks by language." | |
150 | (interactive "fFile to tangle: \nP") | |
151 | (let ((visited-p (get-file-buffer (expand-file-name file))) | |
152 | to-be-removed) | |
153 | (save-window-excursion | |
154 | (find-file file) | |
155 | (setq to-be-removed (current-buffer)) | |
156 | (org-babel-tangle target-file lang)) | |
157 | (unless visited-p | |
158 | (kill-buffer to-be-removed)))) | |
159 | ||
160 | (defun org-babel-tangle-publish (_ filename pub-dir) | |
161 | "Tangle FILENAME and place the results in PUB-DIR." | |
162 | (mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename))) | |
163 | ||
164 | ;;;###autoload | |
165 | (defun org-babel-tangle (&optional target-file lang) | |
166 | "Write code blocks to source-specific files. | |
167 | Extract the bodies of all source code blocks from the current | |
168 | file into their own source-specific files. Optional argument | |
169 | TARGET-FILE can be used to specify a default export file for all | |
170 | source blocks. Optional argument LANG can be used to limit the | |
171 | exported source code blocks by language." | |
172 | (interactive) | |
afe98dfa | 173 | (run-hooks 'org-babel-pre-tangle-hook) |
86fbb8ca CD |
174 | (save-excursion |
175 | (let ((block-counter 0) | |
176 | (org-babel-default-header-args | |
177 | (if target-file | |
178 | (org-babel-merge-params org-babel-default-header-args | |
179 | (list (cons :tangle target-file))) | |
180 | org-babel-default-header-args)) | |
181 | path-collector) | |
182 | (mapc ;; map over all languages | |
183 | (lambda (by-lang) | |
184 | (let* ((lang (car by-lang)) | |
185 | (specs (cdr by-lang)) | |
186 | (ext (or (cdr (assoc lang org-babel-tangle-lang-exts)) lang)) | |
187 | (lang-f (intern | |
188 | (concat | |
189 | (or (and (cdr (assoc lang org-src-lang-modes)) | |
190 | (symbol-name | |
191 | (cdr (assoc lang org-src-lang-modes)))) | |
192 | lang) | |
193 | "-mode"))) | |
194 | she-banged) | |
195 | (mapc | |
196 | (lambda (spec) | |
197 | (flet ((get-spec (name) | |
afe98dfa | 198 | (cdr (assoc name (nth 4 spec))))) |
86fbb8ca CD |
199 | (let* ((tangle (get-spec :tangle)) |
200 | (she-bang ((lambda (sheb) (when (> (length sheb) 0) sheb)) | |
201 | (get-spec :shebang))) | |
202 | (base-name (cond | |
203 | ((string= "yes" tangle) | |
204 | (file-name-sans-extension | |
205 | (buffer-file-name))) | |
206 | ((string= "no" tangle) nil) | |
207 | ((> (length tangle) 0) tangle))) | |
208 | (file-name (when base-name | |
209 | ;; decide if we want to add ext to base-name | |
210 | (if (and ext (string= "yes" tangle)) | |
211 | (concat base-name "." ext) base-name)))) | |
212 | (when file-name | |
213 | ;; delete any old versions of file | |
214 | (when (and (file-exists-p file-name) | |
215 | (not (member file-name path-collector))) | |
216 | (delete-file file-name)) | |
217 | ;; drop source-block to file | |
218 | (with-temp-buffer | |
219 | (when (fboundp lang-f) (funcall lang-f)) | |
220 | (when (and she-bang (not (member file-name she-banged))) | |
221 | (insert (concat she-bang "\n")) | |
222 | (setq she-banged (cons file-name she-banged))) | |
223 | (org-babel-spec-to-string spec) | |
224 | ;; We avoid append-to-file as it does not work with tramp. | |
225 | (let ((content (buffer-string))) | |
226 | (with-temp-buffer | |
227 | (if (file-exists-p file-name) | |
228 | (insert-file-contents file-name)) | |
229 | (goto-char (point-max)) | |
230 | (insert content) | |
231 | (write-region nil nil file-name)))) | |
232 | ;; if files contain she-bangs, then make the executable | |
afe98dfa | 233 | (when she-bang (set-file-modes file-name #o755)) |
86fbb8ca CD |
234 | ;; update counter |
235 | (setq block-counter (+ 1 block-counter)) | |
236 | (add-to-list 'path-collector file-name))))) | |
237 | specs))) | |
238 | (org-babel-tangle-collect-blocks lang)) | |
afe98dfa CD |
239 | (message "tangled %d code block%s from %s" block-counter |
240 | (if (= block-counter 1) "" "s") | |
241 | (file-name-nondirectory (buffer-file-name (current-buffer)))) | |
86fbb8ca CD |
242 | ;; run `org-babel-post-tangle-hook' in all tangled files |
243 | (when org-babel-post-tangle-hook | |
244 | (mapc | |
245 | (lambda (file) | |
246 | (org-babel-with-temp-filebuffer file | |
247 | (run-hooks 'org-babel-post-tangle-hook))) | |
248 | path-collector)) | |
249 | path-collector))) | |
250 | ||
251 | (defun org-babel-tangle-clean () | |
252 | "Remove comments inserted by `org-babel-tangle'. | |
253 | Call this function inside of a source-code file generated by | |
254 | `org-babel-tangle' to remove all comments inserted automatically | |
255 | by `org-babel-tangle'. Warning, this comment removes any lines | |
256 | containing constructs which resemble org-mode file links or noweb | |
257 | references." | |
258 | (interactive) | |
259 | (goto-char (point-min)) | |
260 | (while (or (re-search-forward "\\[\\[file:.*\\]\\[.*\\]\\]" nil t) | |
261 | (re-search-forward "<<[^[:space:]]*>>" nil t)) | |
262 | (delete-region (save-excursion (beginning-of-line 1) (point)) | |
263 | (save-excursion (end-of-line 1) (forward-char 1) (point))))) | |
264 | ||
265 | (defvar org-stored-links) | |
afe98dfa | 266 | (defun org-babel-tangle-collect-blocks (&optional language) |
86fbb8ca CD |
267 | "Collect source blocks in the current Org-mode file. |
268 | Return an association list of source-code block specifications of | |
269 | the form used by `org-babel-spec-to-string' grouped by language. | |
270 | Optional argument LANG can be used to limit the collected source | |
271 | code blocks by language." | |
272 | (let ((block-counter 1) (current-heading "") blocks) | |
273 | (org-babel-map-src-blocks (buffer-file-name) | |
274 | ((lambda (new-heading) | |
275 | (if (not (string= new-heading current-heading)) | |
276 | (progn | |
277 | (setq block-counter 1) | |
278 | (setq current-heading new-heading)) | |
279 | (setq block-counter (+ 1 block-counter)))) | |
280 | (replace-regexp-in-string "[ \t]" "-" | |
afe98dfa CD |
281 | (condition-case nil |
282 | (nth 4 (org-heading-components)) | |
283 | (error (buffer-file-name))))) | |
284 | (let* ((start-line (save-restriction (widen) | |
285 | (+ 1 (line-number-at-pos (point))))) | |
286 | (file (buffer-file-name)) | |
287 | (info (org-babel-get-src-block-info 'light)) | |
288 | (src-lang (nth 0 info))) | |
289 | (unless (string= (cdr (assoc :tangle (nth 2 info))) "no") | |
290 | (unless (and language (not (string= language src-lang))) | |
291 | (let* ((info (org-babel-get-src-block-info)) | |
292 | (params (nth 2 info)) | |
293 | (link (progn (call-interactively 'org-store-link) | |
294 | (org-babel-clean-text-properties | |
295 | (car (pop org-stored-links))))) | |
296 | (source-name | |
297 | (intern (or (nth 4 info) | |
298 | (format "%s:%d" | |
299 | current-heading block-counter)))) | |
300 | (expand-cmd | |
301 | (intern (concat "org-babel-expand-body:" src-lang))) | |
302 | (assignments-cmd | |
303 | (intern (concat "org-babel-variable-assignments:" src-lang))) | |
304 | (body | |
305 | ((lambda (body) | |
306 | (if (assoc :no-expand params) | |
307 | body | |
308 | (if (fboundp expand-cmd) | |
309 | (funcall expand-cmd body params) | |
310 | (org-babel-expand-body:generic | |
311 | body params | |
312 | (and (fboundp assignments-cmd) | |
313 | (funcall assignments-cmd params)))))) | |
314 | (if (and (cdr (assoc :noweb params)) | |
315 | (let ((nowebs (split-string | |
316 | (cdr (assoc :noweb params))))) | |
317 | (or (member "yes" nowebs) | |
318 | (member "tangle" nowebs)))) | |
319 | (org-babel-expand-noweb-references info) | |
320 | (nth 1 info)))) | |
321 | (comment | |
322 | (when (or (string= "both" (cdr (assoc :comments params))) | |
323 | (string= "org" (cdr (assoc :comments params)))) | |
324 | ;; from the previous heading or code-block end | |
325 | (buffer-substring | |
326 | (max (condition-case nil | |
327 | (save-excursion | |
328 | (org-back-to-heading t) (point)) | |
329 | (error 0)) | |
330 | (save-excursion | |
331 | (re-search-backward | |
332 | org-babel-src-block-regexp nil t) | |
333 | (match-end 0))) | |
334 | (point)))) | |
335 | by-lang) | |
336 | ;; add the spec for this block to blocks under it's language | |
337 | (setq by-lang (cdr (assoc src-lang blocks))) | |
338 | (setq blocks (delq (assoc src-lang blocks) blocks)) | |
339 | (setq blocks (cons | |
340 | (cons src-lang | |
341 | (cons (list start-line file link | |
342 | source-name params body comment) | |
343 | by-lang)) blocks))))))) | |
86fbb8ca CD |
344 | ;; ensure blocks in the correct order |
345 | (setq blocks | |
346 | (mapcar | |
347 | (lambda (by-lang) (cons (car by-lang) (reverse (cdr by-lang)))) | |
348 | blocks)) | |
349 | blocks)) | |
350 | ||
351 | (defun org-babel-spec-to-string (spec) | |
352 | "Insert SPEC into the current file. | |
353 | Insert the source-code specified by SPEC into the current | |
354 | source code file. This function uses `comment-region' which | |
355 | assumes that the appropriate major-mode is set. SPEC has the | |
356 | form | |
357 | ||
afe98dfa CD |
358 | (start-line file link source-name params body comment)" |
359 | (let* ((start-line (nth 0 spec)) | |
360 | (file (nth 1 spec)) | |
361 | (link (org-link-escape (nth 2 spec))) | |
362 | (source-name (nth 3 spec)) | |
363 | (body (nth 5 spec)) | |
364 | (comment (nth 6 spec)) | |
365 | (comments (cdr (assoc :comments (nth 4 spec)))) | |
366 | (link-p (or (string= comments "both") (string= comments "link") | |
367 | (string= comments "yes"))) | |
368 | (link-data (mapcar (lambda (el) | |
369 | (cons (symbol-name el) | |
370 | ((lambda (le) | |
371 | (if (stringp le) le (format "%S" le))) | |
372 | (eval el)))) | |
373 | '(start-line file link source-name)))) | |
86fbb8ca | 374 | (flet ((insert-comment (text) |
afe98dfa CD |
375 | (let ((text (org-babel-trim text))) |
376 | (when (and comments (not (string= comments "no")) | |
377 | (> (length text) 0)) | |
378 | (when org-babel-tangle-pad-newline (insert "\n")) | |
379 | (comment-region (point) (progn (insert text) (point))) | |
380 | (end-of-line nil) (insert "\n"))))) | |
381 | (when comment (insert-comment comment)) | |
382 | (when link-p | |
383 | (insert-comment | |
384 | (org-fill-template org-babel-tangle-comment-format-beg link-data))) | |
385 | (when org-babel-tangle-pad-newline (insert "\n")) | |
386 | (insert | |
387 | (format | |
388 | "%s\n" | |
389 | (replace-regexp-in-string | |
390 | "^," "" | |
391 | (org-babel-trim body (if org-src-preserve-indentation "[\f\n\r\v]"))))) | |
392 | (when link-p | |
393 | (insert-comment | |
394 | (org-fill-template org-babel-tangle-comment-format-end link-data)))))) | |
395 | ||
396 | ;; detangling functions | |
397 | (defvar org-bracket-link-analytic-regexp) | |
398 | (defun org-babel-detangle (&optional source-code-file) | |
399 | "Propagate changes in source file back original to Org-mode file. | |
400 | This requires that code blocks were tangled with link comments | |
401 | which enable the original code blocks to be found." | |
402 | (interactive) | |
403 | (save-excursion | |
404 | (when source-code-file (find-file source-code-file)) | |
405 | (goto-char (point-min)) | |
406 | (let ((counter 0) new-body end) | |
407 | (while (re-search-forward org-bracket-link-analytic-regexp nil t) | |
408 | (when (re-search-forward | |
409 | (concat " " (regexp-quote (match-string 5)) " ends here")) | |
410 | (setq end (match-end 0)) | |
411 | (forward-line -1) | |
412 | (save-excursion | |
413 | (when (setq new-body (org-babel-tangle-jump-to-org)) | |
414 | (org-babel-update-block-body new-body))) | |
415 | (setq counter (+ 1 counter))) | |
416 | (goto-char end)) | |
417 | (prog1 counter (message "detangled %d code blocks" counter))))) | |
418 | ||
419 | (defun org-babel-tangle-jump-to-org () | |
420 | "Jump from a tangled code file to the related Org-mode file." | |
421 | (interactive) | |
422 | (let ((mid (point)) | |
423 | target-buffer target-char | |
424 | start end link path block-name body) | |
425 | (save-window-excursion | |
426 | (save-excursion | |
427 | (unless (and (re-search-backward org-bracket-link-analytic-regexp nil t) | |
428 | (setq start (point-at-eol)) | |
429 | (setq link (match-string 0)) | |
430 | (setq path (match-string 3)) | |
431 | (setq block-name (match-string 5)) | |
432 | (re-search-forward | |
433 | (concat " " (regexp-quote block-name) " ends here") nil t) | |
434 | (setq end (point-at-bol)) | |
435 | (< start mid) (< mid end)) | |
436 | (error "not in tangled code")) | |
437 | (setq body (org-babel-trim (buffer-substring start end)))) | |
438 | (when (string-match "::" path) | |
439 | (setq path (substring path 0 (match-beginning 0)))) | |
440 | (find-file path) (setq target-buffer (current-buffer)) | |
441 | (goto-char start) (org-open-link-from-string link) | |
442 | (if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name) | |
443 | (org-babel-next-src-block | |
444 | (string-to-number (match-string 1 block-name))) | |
445 | (org-babel-goto-named-src-block block-name)) | |
446 | (setq target-char (point))) | |
447 | (pop-to-buffer target-buffer) | |
448 | (prog1 body (goto-char target-char)))) | |
86fbb8ca CD |
449 | |
450 | (provide 'ob-tangle) | |
451 | ||
86fbb8ca CD |
452 | |
453 | ;;; ob-tangle.el ends here |