ob-tangle.el (28538B)
1 ;;; ob-tangle.el --- Extract Source Code From Org Files -*- lexical-binding: t; -*- 2 3 ;; Copyright (C) 2009-2023 Free Software Foundation, Inc. 4 5 ;; Author: Eric Schulte 6 ;; Keywords: literate programming, reproducible research 7 ;; URL: 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 'org-macs) 31 (org-assert-version) 32 33 (require 'cl-lib) 34 (require 'org-src) 35 (require 'org-macs) 36 (require 'ol) 37 38 (declare-function make-directory "files" (dir &optional parents)) 39 (declare-function org-at-heading-p "org" (&optional ignored)) 40 (declare-function org-babel-update-block-body "ob-core" (new-body)) 41 (declare-function org-back-to-heading "org" (&optional invisible-ok)) 42 (declare-function org-before-first-heading-p "org" ()) 43 (declare-function org-element--cache-active-p "org-element" ()) 44 (declare-function org-element-lineage "org-element" (datum &optional types with-self)) 45 (declare-function org-element-property "org-element" (property element)) 46 (declare-function org-element-at-point "org-element" (&optional pom cached-only)) 47 (declare-function org-element-type "org-element" (element)) 48 (declare-function org-heading-components "org" ()) 49 (declare-function org-in-commented-heading-p "org" (&optional no-inheritance)) 50 (declare-function org-in-archived-heading-p "org" (&optional no-inheritance)) 51 (declare-function outline-previous-heading "outline" ()) 52 (defvar org-id-link-to-org-use-id) ; Dynamically scoped 53 54 (defgroup org-babel-tangle nil 55 "Options for extracting source code from code blocks." 56 :tag "Org Babel Tangle" 57 :group 'org-babel) 58 59 (defcustom org-babel-tangle-lang-exts 60 '(("emacs-lisp" . "el") 61 ("elisp" . "el")) 62 "Alist mapping languages to their file extensions. 63 The key is the language name, the value is the string that should 64 be inserted as the extension commonly used to identify files 65 written in this language. If no entry is found in this list, 66 then the name of the language is used." 67 :group 'org-babel-tangle 68 :version "24.1" 69 :type '(repeat 70 (cons 71 (string "Language name") 72 (string "File Extension")))) 73 74 (defcustom org-babel-tangle-use-relative-file-links t 75 "Use relative path names in links from tangled source back the Org file." 76 :group 'org-babel-tangle 77 :type 'boolean) 78 79 (defcustom org-babel-post-tangle-hook nil 80 "Hook run in code files tangled by `org-babel-tangle'." 81 :group 'org-babel-tangle 82 :version "24.1" 83 :type 'hook) 84 85 (defcustom org-babel-pre-tangle-hook '(save-buffer) 86 "Hook run at the beginning of `org-babel-tangle' in the original buffer." 87 :group 'org-babel-tangle 88 :version "24.1" 89 :type 'hook) 90 91 (defcustom org-babel-tangle-body-hook nil 92 "Hook run over the contents of each code block body." 93 :group 'org-babel-tangle 94 :version "24.1" 95 :type 'hook) 96 97 (defcustom org-babel-tangle-finished-hook nil 98 "Hook run at the very end of `org-babel-tangle' in the original buffer. 99 In this way, it is the counterpart to `org-babel-pre-tangle-hook'." 100 :group 'org-babel-tangle 101 :package-version '(Org . "9.6") 102 :type 'hook) 103 104 (defcustom org-babel-tangle-comment-format-beg "[[%link][%source-name]]" 105 "Format of inserted comments in tangled code files. 106 The following format strings can be used to insert special 107 information into the output using `org-fill-template'. 108 %start-line --- the line number at the start of the code block 109 %file --------- the file from which the code block was tangled 110 %link --------- Org style link to the code block 111 %source-name -- name of the code block 112 113 Upon insertion the formatted comment will be commented out, and 114 followed by a newline. To inhibit this post-insertion processing 115 set the `org-babel-tangle-uncomment-comments' variable to a 116 non-nil value. 117 118 Whether or not comments are inserted during tangling is 119 controlled by the :comments header argument." 120 :group 'org-babel-tangle 121 :version "24.1" 122 :type 'string) 123 124 (defcustom org-babel-tangle-comment-format-end "%source-name ends here" 125 "Format of inserted comments in tangled code files. 126 The following format strings can be used to insert special 127 information into the output using `org-fill-template'. 128 %start-line --- the line number at the start of the code block 129 %file --------- the file from which the code block was tangled 130 %link --------- Org style link to the code block 131 %source-name -- name of the code block 132 133 Upon insertion the formatted comment will be commented out, and 134 followed by a newline. To inhibit this post-insertion processing 135 set the `org-babel-tangle-uncomment-comments' variable to a 136 non-nil value. 137 138 Whether or not comments are inserted during tangling is 139 controlled by the :comments header argument." 140 :group 'org-babel-tangle 141 :version "24.1" 142 :type 'string) 143 144 (defcustom org-babel-tangle-uncomment-comments nil 145 "Inhibits automatic commenting and addition of trailing newline 146 of tangle comments. Use `org-babel-tangle-comment-format-beg' 147 and `org-babel-tangle-comment-format-end' to customize the format 148 of tangled comments." 149 :group 'org-babel-tangle 150 :type 'boolean) 151 152 (defcustom org-babel-process-comment-text 'org-remove-indentation 153 "Function called to process raw Org text collected to be 154 inserted as comments in tangled source-code files. The function 155 should take a single string argument and return a string 156 result. The default value is `org-remove-indentation'." 157 :group 'org-babel-tangle 158 :version "24.1" 159 :type 'function) 160 161 (defcustom org-babel-tangle-default-file-mode #o544 162 "The default mode used for tangled files, as an integer. 163 The default value 356 correspands to the octal #o544, which is 164 read-write permissions for the user, read-only for everyone else." 165 :group 'org-babel-tangle 166 :package-version '(Org . "9.6") 167 :type 'integer) 168 169 (defun org-babel-find-file-noselect-refresh (file) 170 "Find file ensuring that the latest changes on disk are 171 represented in the file." 172 (find-file-noselect file 'nowarn) 173 (with-current-buffer (get-file-buffer file) 174 (revert-buffer t t t))) 175 176 (defmacro org-babel-with-temp-filebuffer (file &rest body) 177 "Open FILE into a temporary buffer execute BODY there like 178 `progn', then kill the FILE buffer returning the result of 179 evaluating BODY." 180 (declare (indent 1) (debug t)) 181 (let ((temp-path (make-symbol "temp-path")) 182 (temp-result (make-symbol "temp-result")) 183 (temp-file (make-symbol "temp-file")) 184 (visited-p (make-symbol "visited-p"))) 185 `(let* ((,temp-path ,file) 186 (,visited-p (get-file-buffer ,temp-path)) 187 ,temp-result ,temp-file) 188 (org-babel-find-file-noselect-refresh ,temp-path) 189 (setf ,temp-file (get-file-buffer ,temp-path)) 190 (with-current-buffer ,temp-file 191 (setf ,temp-result (progn ,@body))) 192 (unless ,visited-p (kill-buffer ,temp-file)) 193 ,temp-result))) 194 195 ;;;###autoload 196 (defun org-babel-tangle-file (file &optional target-file lang-re) 197 "Extract the bodies of source code blocks in FILE. 198 Source code blocks are extracted with `org-babel-tangle'. 199 200 Optional argument TARGET-FILE can be used to specify a default 201 export file for all source blocks. 202 203 Optional argument LANG-RE can be used to limit the exported 204 source code blocks by languages matching a regular expression. 205 206 Return list of the tangled file names." 207 (interactive "fFile to tangle: \nP") 208 (let* ((visited (find-buffer-visiting file)) 209 (buffer (or visited (find-file-noselect file)))) 210 (prog1 211 (with-current-buffer buffer 212 (org-with-wide-buffer 213 (mapcar #'expand-file-name 214 (org-babel-tangle nil target-file lang-re)))) 215 (unless visited (kill-buffer buffer))))) 216 217 (defun org-babel-tangle-publish (_ filename pub-dir) 218 "Tangle FILENAME and place the results in PUB-DIR." 219 (unless (file-exists-p pub-dir) 220 (make-directory pub-dir t)) 221 (setq pub-dir (file-name-as-directory pub-dir)) 222 (mapc (lambda (el) (copy-file el pub-dir t)) (org-babel-tangle-file filename))) 223 224 ;;;###autoload 225 (defun org-babel-tangle (&optional arg target-file lang-re) 226 "Write code blocks to source-specific files. 227 Extract the bodies of all source code blocks from the current 228 file into their own source-specific files. Return the list of files. 229 With one universal prefix argument, only tangle the block at point. 230 When two universal prefix arguments, only tangle blocks for the 231 tangle file of the block at point. 232 Optional argument TARGET-FILE can be used to specify a default 233 export file for all source blocks. Optional argument LANG-RE can 234 be used to limit the exported source code blocks by languages 235 matching a regular expression." 236 (interactive "P") 237 (run-hooks 'org-babel-pre-tangle-hook) 238 ;; Possibly Restrict the buffer to the current code block 239 (save-restriction 240 (save-excursion 241 (when (equal arg '(4)) 242 (let ((head (org-babel-where-is-src-block-head))) 243 (if head 244 (goto-char head) 245 (user-error "Point is not in a source code block")))) 246 (let ((block-counter 0) 247 (org-babel-default-header-args 248 (if target-file 249 (org-babel-merge-params org-babel-default-header-args 250 (list (cons :tangle target-file))) 251 org-babel-default-header-args)) 252 (tangle-file 253 (when (equal arg '(16)) 254 (or (cdr (assq :tangle (nth 2 (org-babel-get-src-block-info 'no-eval)))) 255 (user-error "Point is not in a source code block")))) 256 path-collector) 257 (mapc ;; map over file-names 258 (lambda (by-fn) 259 (let ((file-name (car by-fn))) 260 (when file-name 261 (let ((lspecs (cdr by-fn)) 262 (fnd (file-name-directory file-name)) 263 modes make-dir she-banged lang) 264 ;; drop source-blocks to file 265 ;; We avoid append-to-file as it does not work with tramp. 266 (with-temp-buffer 267 (mapc 268 (lambda (lspec) 269 (let* ((block-lang (car lspec)) 270 (spec (cdr lspec)) 271 (get-spec (lambda (name) (cdr (assq name (nth 4 spec))))) 272 (she-bang (let ((sheb (funcall get-spec :shebang))) 273 (when (> (length sheb) 0) sheb))) 274 (tangle-mode (funcall get-spec :tangle-mode))) 275 (unless (string-equal block-lang lang) 276 (setq lang block-lang) 277 (let ((lang-f (org-src-get-lang-mode lang))) 278 (when (fboundp lang-f) (ignore-errors (funcall lang-f))))) 279 ;; if file contains she-bangs, then make it executable 280 (when she-bang 281 (unless tangle-mode (setq tangle-mode #o755))) 282 (when tangle-mode 283 (add-to-list 'modes (org-babel-interpret-file-mode tangle-mode))) 284 ;; Possibly create the parent directories for file. 285 (let ((m (funcall get-spec :mkdirp))) 286 (and m fnd (not (string= m "no")) 287 (setq make-dir t))) 288 ;; Handle :padlines unless first line in file 289 (unless (or (string= "no" (funcall get-spec :padline)) 290 (= (point) (point-min))) 291 (insert "\n")) 292 (when (and she-bang (not she-banged)) 293 (insert (concat she-bang "\n")) 294 (setq she-banged t)) 295 (org-babel-spec-to-string spec) 296 (setq block-counter (+ 1 block-counter)))) 297 lspecs) 298 (when make-dir 299 (make-directory fnd 'parents)) 300 (unless 301 (and (file-exists-p file-name) 302 (let ((tangle-buf (current-buffer))) 303 (with-temp-buffer 304 (insert-file-contents file-name) 305 (and 306 (equal (buffer-size) 307 (buffer-size tangle-buf)) 308 (= 0 309 (let (case-fold-search) 310 (compare-buffer-substrings 311 nil nil nil 312 tangle-buf nil nil))))))) 313 ;; erase previous file 314 (when (file-exists-p file-name) 315 (delete-file file-name)) 316 (write-region nil nil file-name) 317 (mapc (lambda (mode) (set-file-modes file-name mode)) modes)) 318 (push file-name path-collector)))))) 319 (if (equal arg '(4)) 320 (org-babel-tangle-single-block 1 t) 321 (org-babel-tangle-collect-blocks lang-re tangle-file))) 322 (message "Tangled %d code block%s from %s" block-counter 323 (if (= block-counter 1) "" "s") 324 (file-name-nondirectory 325 (buffer-file-name 326 (or (buffer-base-buffer) 327 (current-buffer) 328 (and (org-src-edit-buffer-p) 329 (org-src-source-buffer)))))) 330 ;; run `org-babel-post-tangle-hook' in all tangled files 331 (when org-babel-post-tangle-hook 332 (mapc 333 (lambda (file) 334 (org-babel-with-temp-filebuffer file 335 (run-hooks 'org-babel-post-tangle-hook))) 336 path-collector)) 337 (run-hooks 'org-babel-tangle-finished-hook) 338 path-collector)))) 339 340 (defun org-babel-interpret-file-mode (mode) 341 "Determine the integer representation of a file MODE specification. 342 The following forms are currently recognized: 343 - an integer (returned without modification) 344 - \"o755\" (chmod style octal) 345 - \"rwxrw-r--\" (ls style specification) 346 - \"a=rw,u+x\" (chmod style) * 347 348 * The interpretation of these forms relies on `file-modes-symbolic-to-number', 349 and uses `org-babel-tangle-default-file-mode' as the base mode." 350 (cond 351 ((integerp mode) 352 (if (string-match-p "^[0-7][0-7][0-7]$" (format "%o" mode)) 353 mode 354 (user-error "%1$o is not a valid file mode octal. \ 355 Did you give the decimal value %1$d by mistake?" mode))) 356 ((not (stringp mode)) 357 (error "File mode %S not recognized as a valid format." mode)) 358 ((string-match-p "^o0?[0-7][0-7][0-7]$" mode) 359 (string-to-number (replace-regexp-in-string "^o" "" mode) 8)) 360 ((string-match-p "^[ugoa]*\\(?:[+-=][rwxXstugo]*\\)+\\(,[ugoa]*\\(?:[+-=][rwxXstugo]*\\)+\\)*$" mode) 361 ;; Match regexp taken from `file-modes-symbolic-to-number'. 362 (file-modes-symbolic-to-number mode org-babel-tangle-default-file-mode)) 363 ((string-match-p "^[r-][w-][xs-][r-][w-][xs-][r-][w-][x-]$" mode) 364 (file-modes-symbolic-to-number (concat "u=" (substring mode 0 3) 365 ",g=" (substring mode 3 6) 366 ",o=" (substring mode 6 9)) 367 0)) 368 (t (error "File mode %S not recognized as a valid format. See `org-babel-interpret-file-mode'." mode)))) 369 370 (defun org-babel-tangle-clean () 371 "Remove comments inserted by `org-babel-tangle'. 372 Call this function inside of a source-code file generated by 373 `org-babel-tangle' to remove all comments inserted automatically 374 by `org-babel-tangle'. Warning, this comment removes any lines 375 containing constructs which resemble Org file links or noweb 376 references." 377 (interactive) 378 (goto-char (point-min)) 379 (while (or (re-search-forward "\\[\\[file:.*\\]\\[.*\\]\\]" nil t) 380 (re-search-forward (org-babel-noweb-wrap) nil t)) 381 (delete-region (save-excursion (beginning-of-line 1) (point)) 382 (save-excursion (end-of-line 1) (forward-char 1) (point))))) 383 384 (defun org-babel-spec-to-string (spec) 385 "Insert SPEC into the current file. 386 387 Insert the source-code specified by SPEC into the current source 388 code file. This function uses `comment-region' which assumes 389 that the appropriate major-mode is set. SPEC has the form: 390 391 (start-line file link source-name params body comment)" 392 (pcase-let* 393 ((`(,start ,file ,link ,source ,info ,body ,comment) spec) 394 (comments (cdr (assq :comments info))) 395 (link? (or (string= comments "both") (string= comments "link") 396 (string= comments "yes") (string= comments "noweb"))) 397 (link-data `(("start-line" . ,(number-to-string start)) 398 ("file" . ,file) 399 ("link" . ,link) 400 ("source-name" . ,source))) 401 (insert-comment (lambda (text) 402 (when (and comments 403 (not (string= comments "no")) 404 (org-string-nw-p text)) 405 (if org-babel-tangle-uncomment-comments 406 ;; Plain comments: no processing. 407 (insert text) 408 ;; Ensure comments are made to be 409 ;; comments, and add a trailing newline. 410 ;; Also ignore invisible characters when 411 ;; commenting. 412 (comment-region 413 (point) 414 (progn (insert (org-no-properties text)) 415 (point))) 416 (end-of-line) 417 (insert "\n")))))) 418 (when comment (funcall insert-comment comment)) 419 (when link? 420 (funcall insert-comment 421 (org-fill-template 422 org-babel-tangle-comment-format-beg link-data))) 423 (insert body "\n") 424 (when link? 425 (funcall insert-comment 426 (org-fill-template 427 org-babel-tangle-comment-format-end link-data))))) 428 429 (defun org-babel-effective-tangled-filename (buffer-fn src-lang src-tfile) 430 "Return effective tangled filename of a source-code block. 431 BUFFER-FN is the name of the buffer, SRC-LANG the language of the 432 block and SRC-TFILE is the value of the :tangle header argument, 433 as computed by `org-babel-tangle-single-block'." 434 (let ((base-name (cond 435 ((string= "yes" src-tfile) 436 ;; Use the buffer name 437 (file-name-sans-extension buffer-fn)) 438 ((string= "no" src-tfile) nil) 439 ((> (length src-tfile) 0) src-tfile))) 440 (ext (or (cdr (assoc src-lang org-babel-tangle-lang-exts)) src-lang))) 441 (when base-name 442 ;; decide if we want to add ext to base-name 443 (if (and ext (string= "yes" src-tfile)) 444 (concat base-name "." ext) base-name)))) 445 446 (defun org-babel-tangle-collect-blocks (&optional lang-re tangle-file) 447 "Collect source blocks in the current Org file. 448 Return an association list of language and source-code block 449 specifications of the form used by `org-babel-spec-to-string' 450 grouped by tangled file name. 451 452 Optional argument LANG-RE can be used to limit the collected 453 source code blocks by languages matching a regular expression. 454 455 Optional argument TANGLE-FILE can be used to limit the collected 456 code blocks by target file." 457 (let ((counter 0) last-heading-pos blocks) 458 (org-babel-map-src-blocks (buffer-file-name) 459 (let ((current-heading-pos 460 (if (org-element--cache-active-p) 461 (or (org-element-property :begin (org-element-lineage (org-element-at-point) '(headline) t)) 1) 462 (org-with-wide-buffer 463 (org-with-limited-levels (outline-previous-heading)))))) 464 (if (eq last-heading-pos current-heading-pos) (cl-incf counter) 465 (setq counter 1) 466 (setq last-heading-pos current-heading-pos))) 467 (unless (or (org-in-commented-heading-p) 468 (org-in-archived-heading-p)) 469 (let* ((info (org-babel-get-src-block-info 'no-eval)) 470 (src-lang (nth 0 info)) 471 (src-tfile (cdr (assq :tangle (nth 2 info))))) 472 (unless (or (string= src-tfile "no") 473 (and tangle-file (not (equal tangle-file src-tfile))) 474 (and lang-re (not (string-match-p lang-re src-lang)))) 475 ;; Add the spec for this block to blocks under its tangled 476 ;; file name. 477 (let* ((block (org-babel-tangle-single-block counter)) 478 (src-tfile (cdr (assq :tangle (nth 4 block)))) 479 (file-name (org-babel-effective-tangled-filename 480 (nth 1 block) src-lang src-tfile)) 481 (by-fn (assoc file-name blocks))) 482 (if by-fn (setcdr by-fn (cons (cons src-lang block) (cdr by-fn))) 483 (push (cons file-name (list (cons src-lang block))) blocks))))))) 484 ;; Ensure blocks are in the correct order. 485 (mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) 486 (nreverse blocks)))) 487 488 (defun org-babel-tangle--unbracketed-link (params) 489 "Get a raw link to the src block at point, without brackets. 490 491 The PARAMS are the 3rd element of the info for the same src block." 492 (unless (string= "no" (cdr (assq :comments params))) 493 (save-match-data 494 (let* (;; The created link is transient. Using ID is not necessary, 495 ;; but could have side-effects if used. An ID property may 496 ;; be added to existing entries thus creating unexpected file 497 ;; modifications. 498 (org-id-link-to-org-use-id nil) 499 (l (org-no-properties 500 (cl-letf (((symbol-function 'org-store-link-functions) 501 (lambda () nil))) 502 (org-store-link nil)))) 503 (bare (and l 504 (string-match org-link-bracket-re l) 505 (match-string 1 l)))) 506 (when bare 507 (if (and org-babel-tangle-use-relative-file-links 508 (string-match org-link-types-re bare) 509 (string= (match-string 1 bare) "file")) 510 (concat "file:" 511 (file-relative-name (substring bare (match-end 0)) 512 (file-name-directory 513 (cdr (assq :tangle params))))) 514 bare)))))) 515 516 (defun org-babel-tangle-single-block (block-counter &optional only-this-block) 517 "Collect the tangled source for current block. 518 Return the list of block attributes needed by 519 `org-babel-tangle-collect-blocks'. When ONLY-THIS-BLOCK is 520 non-nil, return the full association list to be used by 521 `org-babel-tangle' directly." 522 (let* ((info (org-babel-get-src-block-info)) 523 (start-line 524 (save-restriction (widen) 525 (+ 1 (line-number-at-pos (point))))) 526 (file (buffer-file-name (buffer-base-buffer))) 527 (src-lang (nth 0 info)) 528 (params (nth 2 info)) 529 (extra (nth 3 info)) 530 (coderef (nth 6 info)) 531 (cref-regexp (org-src-coderef-regexp coderef)) 532 (link (org-babel-tangle--unbracketed-link params)) 533 (source-name 534 (or (nth 4 info) 535 (format "%s:%d" 536 (or (ignore-errors (nth 4 (org-heading-components))) 537 "No heading") 538 block-counter))) 539 (expand-cmd (intern (concat "org-babel-expand-body:" src-lang))) 540 (assignments-cmd 541 (intern (concat "org-babel-variable-assignments:" src-lang))) 542 (body 543 ;; Run the tangle-body-hook. 544 (let ((body (if (org-babel-noweb-p params :tangle) 545 (if (string= "strip-tangle" (cdr (assq :noweb (nth 2 info)))) 546 (replace-regexp-in-string (org-babel-noweb-wrap) "" (nth 1 info)) 547 (org-babel-expand-noweb-references info)) 548 (nth 1 info)))) 549 (with-temp-buffer 550 (insert 551 ;; Expand body in language specific manner. 552 (cond ((assq :no-expand params) body) 553 ((fboundp expand-cmd) (funcall expand-cmd body params)) 554 (t 555 (org-babel-expand-body:generic 556 body params (and (fboundp assignments-cmd) 557 (funcall assignments-cmd params)))))) 558 (when (string-match "-r" extra) 559 (goto-char (point-min)) 560 (while (re-search-forward cref-regexp nil t) 561 (replace-match ""))) 562 (run-hooks 'org-babel-tangle-body-hook) 563 (buffer-string)))) 564 (comment 565 (when (or (string= "both" (cdr (assq :comments params))) 566 (string= "org" (cdr (assq :comments params)))) 567 ;; From the previous heading or code-block end 568 (funcall 569 org-babel-process-comment-text 570 (buffer-substring 571 (max (condition-case nil 572 (save-excursion 573 (org-back-to-heading t) ; Sets match data 574 (match-end 0)) 575 (error (point-min))) 576 (save-excursion 577 (if (re-search-backward 578 org-babel-src-block-regexp nil t) 579 (match-end 0) 580 (point-min)))) 581 (point))))) 582 (src-tfile (cdr (assq :tangle params))) 583 (result 584 (list start-line 585 (if org-babel-tangle-use-relative-file-links 586 (file-relative-name file) 587 file) 588 link 589 source-name 590 params 591 (if org-src-preserve-indentation 592 (org-trim body t) 593 (org-trim (org-remove-indentation body))) 594 comment))) 595 (if only-this-block 596 (let* ((file-name (org-babel-effective-tangled-filename 597 (nth 1 result) src-lang src-tfile))) 598 (list (cons file-name (list (cons src-lang result))))) 599 result))) 600 601 (defun org-babel-tangle-comment-links (&optional info) 602 "Return a list of begin and end link comments for the code block at point. 603 INFO, when non nil, is the source block information, as returned 604 by `org-babel-get-src-block-info'." 605 (let ((link-data (pcase (or info (org-babel-get-src-block-info 'no-eval)) 606 (`(,_ ,_ ,params ,_ ,name ,start ,_) 607 `(("start-line" . ,(org-with-point-at start 608 (number-to-string 609 (line-number-at-pos)))) 610 ("file" . ,(buffer-file-name)) 611 ("link" . ,(org-babel-tangle--unbracketed-link params)) 612 ("source-name" . ,name)))))) 613 (list (org-fill-template org-babel-tangle-comment-format-beg link-data) 614 (org-fill-template org-babel-tangle-comment-format-end link-data)))) 615 616 ;; de-tangling functions 617 (defun org-babel-detangle (&optional source-code-file) 618 "Propagate changes in source file back original to Org file. 619 This requires that code blocks were tangled with link comments 620 which enable the original code blocks to be found." 621 (interactive) 622 (save-excursion 623 (when source-code-file (find-file source-code-file)) 624 (goto-char (point-min)) 625 (let ((counter 0) new-body end) 626 (while (re-search-forward org-link-bracket-re nil t) 627 (if (and (match-string 2) 628 (re-search-forward 629 (concat " " (regexp-quote (match-string 2)) " ends here") nil t)) 630 (progn (setq end (match-end 0)) 631 (forward-line -1) 632 (save-excursion 633 (when (setq new-body (org-babel-tangle-jump-to-org)) 634 (org-babel-update-block-body new-body))) 635 (setq counter (+ 1 counter))) 636 (setq end (point))) 637 (goto-char end)) 638 (prog1 counter (message "Detangled %d code blocks" counter))))) 639 640 (defun org-babel-tangle-jump-to-org () 641 "Jump from a tangled code file to the related Org mode file." 642 (interactive) 643 (let ((mid (point)) 644 start body-start end target-buffer target-char link block-name body) 645 (save-window-excursion 646 (save-excursion 647 (while (and (re-search-backward org-link-bracket-re nil t) 648 (not ; ever wider searches until matching block comments 649 (and (setq start (line-beginning-position)) 650 (setq body-start (line-beginning-position 2)) 651 (setq link (match-string 0)) 652 (setq block-name (match-string 2)) 653 (save-excursion 654 (save-match-data 655 (re-search-forward 656 (concat " " (regexp-quote block-name) 657 " ends here") 658 nil t) 659 (setq end (line-beginning-position)))))))) 660 (unless (and start (< start mid) (< mid end)) 661 (error "Not in tangled code")) 662 (setq body (buffer-substring body-start end))) 663 ;; Go to the beginning of the relative block in Org file. 664 ;; Explicitly allow fuzzy search even if user customized 665 ;; otherwise. 666 (let (org-link-search-must-match-exact-headline) 667 (org-link-open-from-string link)) 668 (setq target-buffer (current-buffer)) 669 (if (string-match "[^ \t\n\r]:\\([[:digit:]]+\\)" block-name) 670 (let ((n (string-to-number (match-string 1 block-name)))) 671 (if (org-before-first-heading-p) (goto-char (point-min)) 672 (org-back-to-heading t)) 673 ;; Do not skip the first block if it begins at point min. 674 (cond ((or (org-at-heading-p) 675 (not (eq (org-element-type (org-element-at-point)) 676 'src-block))) 677 (org-babel-next-src-block n)) 678 ((= n 1)) 679 (t (org-babel-next-src-block (1- n))))) 680 (org-babel-goto-named-src-block block-name)) 681 (goto-char (org-babel-where-is-src-block-head)) 682 (forward-line 1) 683 ;; Try to preserve location of point within the source code in 684 ;; tangled code file. 685 (let ((offset (- mid body-start))) 686 (when (> end (+ offset (point))) 687 (forward-char offset))) 688 (setq target-char (point))) 689 (org-src-switch-to-buffer target-buffer t) 690 (goto-char target-char) 691 body)) 692 693 (provide 'ob-tangle) 694 695 ;; Local variables: 696 ;; generated-autoload-file: "org-loaddefs.el" 697 ;; End: 698 699 ;;; ob-tangle.el ends here