| commit | author | age | ||
| 76bbd0 | 1 | ;;; ob-tangle.el --- Extract Source Code From Org Files -*- lexical-binding: t; -*- |
| C | 2 | |
| 3 | ;; Copyright (C) 2009-2018 Free Software Foundation, Inc. | |
| 4 | ||
| 5 | ;; Author: Eric Schulte | |
| 6 | ;; Keywords: literate programming, reproducible research | |
| 7 | ;; Homepage: https://orgmode.org | |
| 8 | ||
| 9 | ;; This file is part of GNU Emacs. | |
| 10 | ||
| 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. | |
| 15 | ||
| 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. | |
| 20 | ||
| 21 | ;; You should have received a copy of the GNU General Public License | |
| 22 | ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. | |
| 23 | ||
| 24 | ;;; Commentary: | |
| 25 | ||
| 26 | ;; Extract the code from source blocks out into raw source-code files. | |
| 27 | ||
| 28 | ;;; Code: | |
| 29 | ||
| 30 | (require 'cl-lib) | |
| 31 | (require 'org-src) | |
| 32 | (require 'org-macs) | |
| 33 | ||
| 34 | (declare-function make-directory "files" (dir &optional parents)) | |
| 35 | (declare-function org-at-heading-p "org" (&optional ignored)) | |
| 36 | (declare-function org-babel-update-block-body "ob-core" (new-body)) | |
| 37 | (declare-function org-back-to-heading "org" (&optional invisible-ok)) | |
| 38 | (declare-function org-before-first-heading-p "org" ()) | |
| 39 | (declare-function org-element-at-point "org-element" ()) | |
| 40 | (declare-function org-element-type "org-element" (element)) | |
| 41 | (declare-function org-fill-template "org" (template alist)) | |
| 42 | (declare-function org-heading-components "org" ()) | |
| 43 | (declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) | |
| 44 | (declare-function org-link-escape "org" (text &optional table merge)) | |
| 45 | (declare-function org-open-link-from-string "org" (s &optional arg reference-buffer)) | |
| 46 | (declare-function org-remove-indentation "org" (code &optional n)) | |
| 47 | (declare-function org-store-link "org" (arg)) | |
| 48 | (declare-function org-trim "org" (s &optional keep-lead)) | |
| 49 | (declare-function outline-previous-heading "outline" ()) | |
| 50 | (declare-function org-id-find "org-id" (id &optional markerp)) | |
| 51 | ||
| 52 | (defvar org-link-types-re) | |
| 53 | ||
| 54 | (defcustom org-babel-tangle-lang-exts | |
| 55 | '(("emacs-lisp" . "el") | |
| 56 | ("elisp" . "el")) | |
| 57 | "Alist mapping languages to their file extensions. | |
| 58 | The key is the language name, the value is the string that should | |
| 59 | be inserted as the extension commonly used to identify files | |
| 60 | written in this language. If no entry is found in this list, | |
| 61 | then the name of the language is used." | |
| 62 | :group 'org-babel-tangle | |
| 63 | :version "24.1" | |
| 64 | :type '(repeat | |
| 65 | (cons | |
| 66 | (string "Language name") | |
| 67 | (string "File Extension")))) | |
| 68 | ||
| 69 | (defcustom org-babel-tangle-use-relative-file-links t | |
| 70 | "Use relative path names in links from tangled source back the Org file." | |
| 71 | :group 'org-babel-tangle | |
| 72 | :type 'boolean) | |
| 73 | ||
| 74 | (defcustom org-babel-post-tangle-hook nil | |
| 75 | "Hook run in code files tangled by `org-babel-tangle'." | |
| 76 | :group 'org-babel | |
| 77 | :version "24.1" | |
| 78 | :type 'hook) | |
| 79 | ||
| 80 | (defcustom org-babel-pre-tangle-hook '(save-buffer) | |
| 81 | "Hook run at the beginning of `org-babel-tangle'." | |
| 82 | :group 'org-babel | |
| 83 | :version "24.1" | |
| 84 | :type 'hook) | |
| 85 | ||
| 86 | (defcustom org-babel-tangle-body-hook nil | |
| 87 | "Hook run over the contents of each code block body." | |
| 88 | :group 'org-babel | |
| 89 | :version "24.1" | |
| 90 | :type 'hook) | |
| 91 | ||
| 92 | (defcustom org-babel-tangle-comment-format-beg "[[%link][%source-name]]" | |
| 93 | "Format of inserted comments in tangled code files. | |
| 94 | The following format strings can be used to insert special | |
| 95 | information into the output using `org-fill-template'. | |
| 96 | %start-line --- the line number at the start of the code block | |
| 97 | %file --------- the file from which the code block was tangled | |
| 98 | %link --------- Org style link to the code block | |
| 99 | %source-name -- name of the code block | |
| 100 | ||
| 101 | Upon insertion the formatted comment will be commented out, and | |
| 102 | followed by a newline. To inhibit this post-insertion processing | |
| 103 | set the `org-babel-tangle-uncomment-comments' variable to a | |
| 104 | non-nil value. | |
| 105 | ||
| 106 | Whether or not comments are inserted during tangling is | |
| 107 | controlled by the :comments header argument." | |
| 108 | :group 'org-babel | |
| 109 | :version "24.1" | |
| 110 | :type 'string) | |
| 111 | ||
| 112 | (defcustom org-babel-tangle-comment-format-end "%source-name ends here" | |
| 113 | "Format of inserted comments in tangled code files. | |
| 114 | The following format strings can be used to insert special | |
| 115 | information into the output using `org-fill-template'. | |
| 116 | %start-line --- the line number at the start of the code block | |
| 117 | %file --------- the file from which the code block was tangled | |
| 118 | %link --------- Org style link to the code block | |
| 119 | %source-name -- name of the code block | |
| 120 | ||
| 121 | Upon insertion the formatted comment will be commented out, and | |
| 122 | followed by a newline. To inhibit this post-insertion processing | |
| 123 | set the `org-babel-tangle-uncomment-comments' variable to a | |
| 124 | non-nil value. | |
| 125 | ||
| 126 | Whether or not comments are inserted during tangling is | |
| 127 | controlled by the :comments header argument." | |
| 128 | :group 'org-babel | |
| 129 | :version "24.1" | |
| 130 | :type 'string) | |
| 131 | ||
| 132 | (defcustom org-babel-tangle-uncomment-comments nil | |
| 133 | "Inhibits automatic commenting and addition of trailing newline | |
| 134 | of tangle comments. Use `org-babel-tangle-comment-format-beg' | |
| 135 | and `org-babel-tangle-comment-format-end' to customize the format | |
| 136 | of tangled comments." | |
| 137 | :group 'org-babel | |
| 138 | :type 'boolean) | |
| 139 | ||
| 140 | (defcustom org-babel-process-comment-text 'org-remove-indentation | |
| 141 | "Function called to process raw Org text collected to be | |
| 142 | inserted as comments in tangled source-code files. The function | |
| 143 | should take a single string argument and return a string | |
| 144 | result. The default value is `org-remove-indentation'." | |
| 145 | :group 'org-babel | |
| 146 | :version "24.1" | |
| 147 | :type 'function) | |
| 148 | ||
| 149 | (defun org-babel-find-file-noselect-refresh (file) | |
| 150 | "Find file ensuring that the latest changes on disk are | |
| 151 | represented in the file." | |
| 152 | (find-file-noselect file 'nowarn) | |
| 153 | (with-current-buffer (get-file-buffer file) | |
| 154 | (revert-buffer t t t))) | |
| 155 | ||
| 156 | (defmacro org-babel-with-temp-filebuffer (file &rest body) | |
| 157 | "Open FILE into a temporary buffer execute BODY there like | |
| 158 | `progn', then kill the FILE buffer returning the result of | |
| 159 | evaluating BODY." | |
| 160 | (declare (indent 1)) | |
| 161 | (let ((temp-path (make-symbol "temp-path")) | |
| 162 | (temp-result (make-symbol "temp-result")) | |
| 163 | (temp-file (make-symbol "temp-file")) | |
| 164 | (visited-p (make-symbol "visited-p"))) | |
| 165 | `(let* ((,temp-path ,file) | |
| 166 | (,visited-p (get-file-buffer ,temp-path)) | |
| 167 | ,temp-result ,temp-file) | |
| 168 | (org-babel-find-file-noselect-refresh ,temp-path) | |
| 169 | (setf ,temp-file (get-file-buffer ,temp-path)) | |
| 170 | (with-current-buffer ,temp-file | |
| 171 | (setf ,temp-result (progn ,@body))) | |
| 172 | (unless ,visited-p (kill-buffer ,temp-file)) | |
| 173 | ,temp-result))) | |
| 174 | (def-edebug-spec org-babel-with-temp-filebuffer (form body)) | |
| 175 | ||
| 176 | ;;;###autoload | |
| 177 | (defun org-babel-tangle-file (file &optional target-file lang) | |
| 178 | "Extract the bodies of source code blocks in FILE. | |
| 179 | Source code blocks are extracted with `org-babel-tangle'. | |
| 180 | Optional argument TARGET-FILE can be used to specify a default | |
| 181 | export file for all source blocks. Optional argument LANG can be | |
| 182 | used to limit the exported source code blocks by language. | |
| 183 | Return a list whose CAR is the tangled file name." | |
| 184 | (interactive "fFile to tangle: \nP") | |
| 185 | (let ((visited-p (get-file-buffer (expand-file-name file))) | |
| 186 | to-be-removed) | |
| 187 | (prog1 | |
| 188 | (save-window-excursion | |
| 189 | (find-file file) | |
| 190 | (setq to-be-removed (current-buffer)) | |
| 191 | (mapcar #'expand-file-name (org-babel-tangle nil target-file lang))) | |
| 192 | (unless visited-p | |
| 193 | (kill-buffer to-be-removed))))) | |
| 194 | ||
| 195 | (defun org-babel-tangle-publish (_ filename pub-dir) | |
| 196 | "Tangle FILENAME and place the results in PUB-DIR." | |
| 197 | (unless (file-exists-p pub-dir) | |
| 198 | (make-directory pub-dir t)) | |
| 199 | (setq pub-dir (file-name-as-directory pub-dir)) | |
| 200 | (mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename))) | |
| 201 | ||
| 202 | ;;;###autoload | |
| 203 | (defun org-babel-tangle (&optional arg target-file lang) | |
| 204 | "Write code blocks to source-specific files. | |
| 205 | Extract the bodies of all source code blocks from the current | |
| 206 | file into their own source-specific files. | |
| 207 | With one universal prefix argument, only tangle the block at point. | |
| 208 | When two universal prefix arguments, only tangle blocks for the | |
| 209 | tangle file of the block at point. | |
| 210 | Optional argument TARGET-FILE can be used to specify a default | |
| 211 | export file for all source blocks. Optional argument LANG can be | |
| 212 | used to limit the exported source code blocks by language." | |
| 213 | (interactive "P") | |
| 214 | (run-hooks 'org-babel-pre-tangle-hook) | |
| 215 | ;; Possibly Restrict the buffer to the current code block | |
| 216 | (save-restriction | |
| 217 | (save-excursion | |
| 218 | (when (equal arg '(4)) | |
| 219 | (let ((head (org-babel-where-is-src-block-head))) | |
| 220 | (if head | |
| 221 | (goto-char head) | |
| 222 | (user-error "Point is not in a source code block")))) | |
| 223 | (let ((block-counter 0) | |
| 224 | (org-babel-default-header-args | |
| 225 | (if target-file | |
| 226 | (org-babel-merge-params org-babel-default-header-args | |
| 227 | (list (cons :tangle target-file))) | |
| 228 | org-babel-default-header-args)) | |
| 229 | (tangle-file | |
| 230 | (when (equal arg '(16)) | |
| 231 | (or (cdr (assq :tangle (nth 2 (org-babel-get-src-block-info 'light)))) | |
| 232 | (user-error "Point is not in a source code block")))) | |
| 233 | path-collector) | |
| 234 | (mapc ;; map over all languages | |
| 235 | (lambda (by-lang) | |
| 236 | (let* ((lang (car by-lang)) | |
| 237 | (specs (cdr by-lang)) | |
| 238 | (ext (or (cdr (assoc lang org-babel-tangle-lang-exts)) lang)) | |
| 239 | (lang-f (intern | |
| 240 | (concat | |
| 241 | (or (and (cdr (assoc lang org-src-lang-modes)) | |
| 242 | (symbol-name | |
| 243 | (cdr (assoc lang org-src-lang-modes)))) | |
| 244 | lang) | |
| 245 | "-mode"))) | |
| 246 | she-banged) | |
| 247 | (mapc | |
| 248 | (lambda (spec) | |
| 249 | (let ((get-spec (lambda (name) (cdr (assoc name (nth 4 spec)))))) | |
| 250 | (let* ((tangle (funcall get-spec :tangle)) | |
| 251 | (she-bang (let ((sheb (funcall get-spec :shebang))) | |
| 252 | (when (> (length sheb) 0) sheb))) | |
| 253 | (tangle-mode (funcall get-spec :tangle-mode)) | |
| 254 | (base-name (cond | |
| 255 | ((string= "yes" tangle) | |
| 256 | (file-name-sans-extension | |
| 257 | (nth 1 spec))) | |
| 258 | ((string= "no" tangle) nil) | |
| 259 | ((> (length tangle) 0) tangle))) | |
| 260 | (file-name (when base-name | |
| 261 | ;; decide if we want to add ext to base-name | |
| 262 | (if (and ext (string= "yes" tangle)) | |
| 263 | (concat base-name "." ext) base-name)))) | |
| 264 | (when file-name | |
| 265 | ;; Possibly create the parent directories for file. | |
| 266 | (let ((m (funcall get-spec :mkdirp)) | |
| 267 | (fnd (file-name-directory file-name))) | |
| 268 | (and m fnd (not (string= m "no")) | |
| 269 | (make-directory fnd 'parents))) | |
| 270 | ;; delete any old versions of file | |
| 271 | (and (file-exists-p file-name) | |
| 272 | (not (member file-name (mapcar #'car path-collector))) | |
| 273 | (delete-file file-name)) | |
| 274 | ;; drop source-block to file | |
| 275 | (with-temp-buffer | |
| 276 | (when (fboundp lang-f) (ignore-errors (funcall lang-f))) | |
| 277 | (when (and she-bang (not (member file-name she-banged))) | |
| 278 | (insert (concat she-bang "\n")) | |
| 279 | (setq she-banged (cons file-name she-banged))) | |
| 280 | (org-babel-spec-to-string spec) | |
| 281 | ;; We avoid append-to-file as it does not work with tramp. | |
| 282 | (let ((content (buffer-string))) | |
| 283 | (with-temp-buffer | |
| 284 | (when (file-exists-p file-name) | |
| 285 | (insert-file-contents file-name)) | |
| 286 | (goto-char (point-max)) | |
| 287 | ;; Handle :padlines unless first line in file | |
| 288 | (unless (or (string= "no" (cdr (assq :padline (nth 4 spec)))) | |
| 289 | (= (point) (point-min))) | |
| 290 | (insert "\n")) | |
| 291 | (insert content) | |
| 292 | (write-region nil nil file-name)))) | |
| 293 | ;; if files contain she-bangs, then make the executable | |
| 294 | (when she-bang | |
| 295 | (unless tangle-mode (setq tangle-mode #o755))) | |
| 296 | ;; update counter | |
| 297 | (setq block-counter (+ 1 block-counter)) | |
| 298 | (unless (assoc file-name path-collector) | |
| 299 | (push (cons file-name tangle-mode) path-collector)))))) | |
| 300 | specs))) | |
| 301 | (if (equal arg '(4)) | |
| 302 | (org-babel-tangle-single-block 1 t) | |
| 303 | (org-babel-tangle-collect-blocks lang tangle-file))) | |
| 304 | (message "Tangled %d code block%s from %s" block-counter | |
| 305 | (if (= block-counter 1) "" "s") | |
| 306 | (file-name-nondirectory | |
| 307 | (buffer-file-name | |
| 308 | (or (buffer-base-buffer) (current-buffer))))) | |
| 309 | ;; run `org-babel-post-tangle-hook' in all tangled files | |
| 310 | (when org-babel-post-tangle-hook | |
| 311 | (mapc | |
| 312 | (lambda (file) | |
| 313 | (org-babel-with-temp-filebuffer file | |
| 314 | (run-hooks 'org-babel-post-tangle-hook))) | |
| 315 | (mapcar #'car path-collector))) | |
| 316 | ;; set permissions on tangled files | |
| 317 | (mapc (lambda (pair) | |
| 318 | (when (cdr pair) (set-file-modes (car pair) (cdr pair)))) | |
| 319 | path-collector) | |
| 320 | (mapcar #'car path-collector))))) | |
| 321 | ||
| 322 | (defun org-babel-tangle-clean () | |
| 323 | "Remove comments inserted by `org-babel-tangle'. | |
| 324 | Call this function inside of a source-code file generated by | |
| 325 | `org-babel-tangle' to remove all comments inserted automatically | |
| 326 | by `org-babel-tangle'. Warning, this comment removes any lines | |
| 327 | containing constructs which resemble Org file links or noweb | |
| 328 | references." | |
| 329 | (interactive) | |
| 330 | (goto-char (point-min)) | |
| 331 | (while (or (re-search-forward "\\[\\[file:.*\\]\\[.*\\]\\]" nil t) | |
| 332 | (re-search-forward (org-babel-noweb-wrap) nil t)) | |
| 333 | (delete-region (save-excursion (beginning-of-line 1) (point)) | |
| 334 | (save-excursion (end-of-line 1) (forward-char 1) (point))))) | |
| 335 | ||
| 336 | (defvar org-stored-links) | |
| 337 | (defvar org-bracket-link-regexp) | |
| 338 | (defun org-babel-spec-to-string (spec) | |
| 339 | "Insert SPEC into the current file. | |
| 340 | ||
| 341 | Insert the source-code specified by SPEC into the current source | |
| 342 | code file. This function uses `comment-region' which assumes | |
| 343 | that the appropriate major-mode is set. SPEC has the form: | |
| 344 | ||
| 345 | (start-line file link source-name params body comment)" | |
| 346 | (pcase-let* | |
| 347 | ((`(,start ,file ,link ,source ,info ,body ,comment) spec) | |
| 348 | (comments (cdr (assq :comments info))) | |
| 349 | (link? (or (string= comments "both") (string= comments "link") | |
| 350 | (string= comments "yes") (string= comments "noweb"))) | |
| 351 | (link-data `(("start-line" . ,(number-to-string start)) | |
| 352 | ("file" . ,file) | |
| 353 | ("link" . ,link) | |
| 354 | ("source-name" . ,source))) | |
| 355 | (insert-comment (lambda (text) | |
| 356 | (when (and comments | |
| 357 | (not (string= comments "no")) | |
| 358 | (org-string-nw-p text)) | |
| 359 | (if org-babel-tangle-uncomment-comments | |
| 360 | ;; Plain comments: no processing. | |
| 361 | (insert text) | |
| 362 | ;; Ensure comments are made to be | |
| 363 | ;; comments, and add a trailing newline. | |
| 364 | ;; Also ignore invisible characters when | |
| 365 | ;; commenting. | |
| 366 | (comment-region | |
| 367 | (point) | |
| 368 | (progn (insert (org-no-properties text)) | |
| 369 | (point))) | |
| 370 | (end-of-line) | |
| 371 | (insert "\n")))))) | |
| 372 | (when comment (funcall insert-comment comment)) | |
| 373 | (when link? | |
| 374 | (funcall insert-comment | |
| 375 | (org-fill-template | |
| 376 | org-babel-tangle-comment-format-beg link-data))) | |
| 377 | (insert body "\n") | |
| 378 | (when link? | |
| 379 | (funcall insert-comment | |
| 380 | (org-fill-template | |
| 381 | org-babel-tangle-comment-format-end link-data))))) | |
| 382 | ||
| 383 | (defun org-babel-tangle-collect-blocks (&optional language tangle-file) | |
| 384 | "Collect source blocks in the current Org file. | |
| 385 | Return an association list of source-code block specifications of | |
| 386 | the form used by `org-babel-spec-to-string' grouped by language. | |
| 387 | Optional argument LANGUAGE can be used to limit the collected | |
| 388 | source code blocks by language. Optional argument TANGLE-FILE | |
| 389 | can be used to limit the collected code blocks by target file." | |
| 390 | (let ((counter 0) last-heading-pos blocks) | |
| 391 | (org-babel-map-src-blocks (buffer-file-name) | |
| 392 | (let ((current-heading-pos | |
| 393 | (org-with-wide-buffer | |
| 394 | (org-with-limited-levels (outline-previous-heading))))) | |
| 395 | (if (eq last-heading-pos current-heading-pos) (cl-incf counter) | |
| 396 | (setq counter 1) | |
| 397 | (setq last-heading-pos current-heading-pos))) | |
| 398 | (unless (org-in-commented-heading-p) | |
| 399 | (let* ((info (org-babel-get-src-block-info 'light)) | |
| 400 | (src-lang (nth 0 info)) | |
| 401 | (src-tfile (cdr (assq :tangle (nth 2 info))))) | |
| 402 | (unless (or (string= src-tfile "no") | |
| 403 | (and tangle-file (not (equal tangle-file src-tfile))) | |
| 404 | (and language (not (string= language src-lang)))) | |
| 405 | ;; Add the spec for this block to blocks under its | |
| 406 | ;; language. | |
| 407 | (let ((by-lang (assoc src-lang blocks)) | |
| 408 | (block (org-babel-tangle-single-block counter))) | |
| 409 | (if by-lang (setcdr by-lang (cons block (cdr by-lang))) | |
| 410 | (push (cons src-lang (list block)) blocks))))))) | |
| 411 | ;; Ensure blocks are in the correct order. | |
| 412 | (mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) blocks))) | |
| 413 | ||
| 414 | (defun org-babel-tangle-single-block (block-counter &optional only-this-block) | |
| 415 | "Collect the tangled source for current block. | |
| 416 | Return the list of block attributes needed by | |
| 417 | `org-babel-tangle-collect-blocks'. When ONLY-THIS-BLOCK is | |
| 418 | non-nil, return the full association list to be used by | |
| 419 | `org-babel-tangle' directly." | |
| 420 | (let* ((info (org-babel-get-src-block-info)) | |
| 421 | (start-line | |
| 422 | (save-restriction (widen) | |
| 423 | (+ 1 (line-number-at-pos (point))))) | |
| 424 | (file (buffer-file-name (buffer-base-buffer))) | |
| 425 | (src-lang (nth 0 info)) | |
| 426 | (params (nth 2 info)) | |
| 427 | (extra (nth 3 info)) | |
| 428 | (cref-fmt (or (and (string-match "-l \"\\(.+\\)\"" extra) | |
| 429 | (match-string 1 extra)) | |
| 430 | org-coderef-label-format)) | |
| 431 | (link (let ((l (org-no-properties (org-store-link nil)))) | |
| 432 | (and (string-match org-bracket-link-regexp l) | |
| 433 | (match-string 1 l)))) | |
| 434 | (source-name | |
| 435 | (or (nth 4 info) | |
| 436 | (format "%s:%d" | |
| 437 | (or (ignore-errors (nth 4 (org-heading-components))) | |
| 438 | "No heading") | |
| 439 | block-counter))) | |
| 440 | (expand-cmd (intern (concat "org-babel-expand-body:" src-lang))) | |
| 441 | (assignments-cmd | |
| 442 | (intern (concat "org-babel-variable-assignments:" src-lang))) | |
| 443 | (body | |
| 444 | ;; Run the tangle-body-hook. | |
| 445 | (let ((body (if (org-babel-noweb-p params :tangle) | |
| 446 | (org-babel-expand-noweb-references info) | |
| 447 | (nth 1 info)))) | |
| 448 | (with-temp-buffer | |
| 449 | (insert | |
| 450 | ;; Expand body in language specific manner. | |
| 451 | (cond ((assq :no-expand params) body) | |
| 452 | ((fboundp expand-cmd) (funcall expand-cmd body params)) | |
| 453 | (t | |
| 454 | (org-babel-expand-body:generic | |
| 455 | body params (and (fboundp assignments-cmd) | |
| 456 | (funcall assignments-cmd params)))))) | |
| 457 | (when (string-match "-r" extra) | |
| 458 | (goto-char (point-min)) | |
| 459 | (while (re-search-forward | |
| 460 | (replace-regexp-in-string "%s" ".+" cref-fmt) nil t) | |
| 461 | (replace-match ""))) | |
| 462 | (run-hooks 'org-babel-tangle-body-hook) | |
| 463 | (buffer-string)))) | |
| 464 | (comment | |
| 465 | (when (or (string= "both" (cdr (assq :comments params))) | |
| 466 | (string= "org" (cdr (assq :comments params)))) | |
| 467 | ;; From the previous heading or code-block end | |
| 468 | (funcall | |
| 469 | org-babel-process-comment-text | |
| 470 | (buffer-substring | |
| 471 | (max (condition-case nil | |
| 472 | (save-excursion | |
| 473 | (org-back-to-heading t) ; Sets match data | |
| 474 | (match-end 0)) | |
| 475 | (error (point-min))) | |
| 476 | (save-excursion | |
| 477 | (if (re-search-backward | |
| 478 | org-babel-src-block-regexp nil t) | |
| 479 | (match-end 0) | |
| 480 | (point-min)))) | |
| 481 | (point))))) | |
| 482 | (result | |
| 483 | (list start-line | |
| 484 | (if org-babel-tangle-use-relative-file-links | |
| 485 | (file-relative-name file) | |
| 486 | file) | |
| 487 | (if (and org-babel-tangle-use-relative-file-links | |
| 488 | (string-match org-link-types-re link) | |
| 489 | (string= (match-string 0 link) "file")) | |
| 490 | (concat "file:" | |
| 491 | (file-relative-name (match-string 1 link) | |
| 492 | (file-name-directory | |
| 493 | (cdr (assq :tangle params))))) | |
| 494 | link) | |
| 495 | source-name | |
| 496 | params | |
| 497 | (if org-src-preserve-indentation | |
| 498 | (org-trim body t) | |
| 499 | (org-trim (org-remove-indentation body))) | |
| 500 | comment))) | |
| 501 | (if only-this-block | |
| 502 | (list (cons src-lang (list result))) | |
| 503 | result))) | |
| 504 | ||
| 505 | (defun org-babel-tangle-comment-links (&optional info) | |
| 506 | "Return a list of begin and end link comments for the code block at point." | |
| 507 | (let ((link-data | |
| 508 | `(("start-line" . ,(number-to-string | |
| 509 | (org-babel-where-is-src-block-head))) | |
| 510 | ("file" . ,(buffer-file-name)) | |
| 511 | ("link" . ,(org-link-escape | |
| 512 | (progn | |
| 513 | (call-interactively #'org-store-link) | |
| 514 | (org-no-properties (car (pop org-stored-links)))))) | |
| 515 | ("source-name" . | |
| 516 | ,(nth 4 (or info (org-babel-get-src-block-info 'light))))))) | |
| 517 | (list (org-fill-template org-babel-tangle-comment-format-beg link-data) | |
| 518 | (org-fill-template org-babel-tangle-comment-format-end link-data)))) | |
| 519 | ||
| 520 | ;; de-tangling functions | |
| 521 | (defvar org-bracket-link-analytic-regexp) | |
| 522 | (defun org-babel-detangle (&optional source-code-file) | |
| 523 | "Propagate changes in source file back original to Org file. | |
| 524 | This requires that code blocks were tangled with link comments | |
| 525 | which enable the original code blocks to be found." | |
| 526 | (interactive) | |
| 527 | (save-excursion | |
| 528 | (when source-code-file (find-file source-code-file)) | |
| 529 | (goto-char (point-min)) | |
| 530 | (let ((counter 0) new-body end) | |
| 531 | (while (re-search-forward org-bracket-link-analytic-regexp nil t) | |
| 532 | (when (re-search-forward | |
| 533 | (concat " " (regexp-quote (match-string 5)) " ends here")) | |
| 534 | (setq end (match-end 0)) | |
| 535 | (forward-line -1) | |
| 536 | (save-excursion | |
| 537 | (when (setq new-body (org-babel-tangle-jump-to-org)) | |
| 538 | (org-babel-update-block-body new-body))) | |
| 539 | (setq counter (+ 1 counter))) | |
| 540 | (goto-char end)) | |
| 541 | (prog1 counter (message "Detangled %d code blocks" counter))))) | |
| 542 | ||
| 543 | (defun org-babel-tangle-jump-to-org () | |
| 544 | "Jump from a tangled code file to the related Org mode file." | |
| 545 | (interactive) | |
| 546 | (let ((mid (point)) | |
| 547 | start body-start end | |
| 548 | target-buffer target-char link path block-name body) | |
| 549 | (save-window-excursion | |
| 550 | (save-excursion | |
| 551 | (while (and (re-search-backward org-bracket-link-analytic-regexp nil t) | |
| 552 | (not ; ever wider searches until matching block comments | |
| 553 | (and (setq start (line-beginning-position)) | |
| 554 | (setq body-start (line-beginning-position 2)) | |
| 555 | (setq link (match-string 0)) | |
| 556 | (setq path (match-string 3)) | |
| 557 | (setq block-name (match-string 5)) | |
| 558 | (save-excursion | |
| 559 | (save-match-data | |
| 560 | (re-search-forward | |
| 561 | (concat " " (regexp-quote block-name) | |
| 562 | " ends here") nil t) | |
| 563 | (setq end (line-beginning-position)))))))) | |
| 564 | (unless (and start (< start mid) (< mid end)) | |
| 565 | (error "Not in tangled code")) | |
| 566 | (setq body (buffer-substring body-start end))) | |
| 567 | (when (string-match "::" path) | |
| 568 | (setq path (substring path 0 (match-beginning 0)))) | |
| 569 | (find-file (or (car (org-id-find path)) path)) | |
| 570 | (setq target-buffer (current-buffer)) | |
| 571 | ;; Go to the beginning of the relative block in Org file. | |
| 572 | (org-open-link-from-string link) | |
| 573 | (if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name) | |
| 574 | (let ((n (string-to-number (match-string 1 block-name)))) | |
| 575 | (if (org-before-first-heading-p) (goto-char (point-min)) | |
| 576 | (org-back-to-heading t)) | |
| 577 | ;; Do not skip the first block if it begins at point min. | |
| 578 | (cond ((or (org-at-heading-p) | |
| 579 | (not (eq (org-element-type (org-element-at-point)) | |
| 580 | 'src-block))) | |
| 581 | (org-babel-next-src-block n)) | |
| 582 | ((= n 1)) | |
| 583 | (t (org-babel-next-src-block (1- n))))) | |
| 584 | (org-babel-goto-named-src-block block-name)) | |
| 585 | (goto-char (org-babel-where-is-src-block-head)) | |
| 586 | ;; Preserve location of point within the source code in tangled | |
| 587 | ;; code file. | |
| 588 | (forward-line 1) | |
| 589 | (forward-char (- mid body-start)) | |
| 590 | (setq target-char (point))) | |
| 591 | (org-src-switch-to-buffer target-buffer t) | |
| 592 | (goto-char target-char) | |
| 593 | body)) | |
| 594 | ||
| 595 | (provide 'ob-tangle) | |
| 596 | ||
| 597 | ;; Local variables: | |
| 598 | ;; generated-autoload-file: "org-loaddefs.el" | |
| 599 | ;; End: | |
| 600 | ||
| 601 | ;;; ob-tangle.el ends here | |
