From 13df19cc7696ca38c3ff2002a4ae2537ec1d330e Mon Sep 17 00:00:00 2001 From: llcc Date: Fri, 4 Apr 2025 20:47:11 +0800 Subject: [PATCH] ob-tangle.el: Support tangling a source block to multiple targets * lisp/ob-tangle.el (org-babel-tangle--concat-targets): Add support for the :tangle-directory header argument to specify a target directory. Both :tangle and :tangle-directory can now accept a string path, a list of paths, or a variable/function that returns a path string or a list of them. (org-babel-tangle-single-block, org-babel-tangle-collect-blocks): Modify return values to use a nested list structure that supports multiple tangle targets per block. * testing/lisp/test-ob-tangle.el (ob-tangle/collect-blocks): Extend tests to cover :tangle-directory and multiple target tangling scenarios. --- lisp/ob-tangle.el | 88 ++++++++++++++++++++++------------ testing/lisp/test-ob-tangle.el | 57 ++++++++++++++++++---- 2 files changed, 107 insertions(+), 38 deletions(-) diff --git a/lisp/ob-tangle.el b/lisp/ob-tangle.el index 38cad78ab..fb2ef4d57 100644 --- a/lisp/ob-tangle.el +++ b/lisp/ob-tangle.el @@ -491,7 +491,6 @@ source code blocks by languages matching a regular expression. Optional argument TANGLE-FILE can be used to limit the collected code blocks by target file." (let ((counter 0) - (buffer-fn (buffer-file-name (buffer-base-buffer))) last-heading-pos blocks) (org-babel-map-src-blocks (buffer-file-name) (let ((current-heading-pos @@ -500,34 +499,30 @@ code blocks by target file." (org-element-at-point) 'headline t)) 1))) - (if (eq last-heading-pos current-heading-pos) (cl-incf counter) - (setq counter 1) - (setq last-heading-pos current-heading-pos))) + (if (eq last-heading-pos current-heading-pos) (cl-incf counter) + (setq counter 1) + (setq last-heading-pos current-heading-pos))) (unless (or (org-in-commented-heading-p) (org-in-archived-heading-p)) - (let* ((info (org-babel-get-src-block-info 'no-eval)) - (src-lang (nth 0 info)) - (src-tfile (cdr (assq :tangle (nth 2 info))))) - (unless (or (string= src-tfile "no") - ;; src block without lang - (and (not src-lang) (string= src-tfile "yes")) - (and tangle-file (not (equal tangle-file src-tfile))) - ;; lang-re but either no lang or lang doesn't match - (and lang-re - (or (not src-lang) - (not (string-match-p lang-re src-lang))))) - ;; Add the spec for this block to blocks under its tangled - ;; file name. - (let* ((block (org-babel-tangle-single-block counter)) - (src-tfile (cdr (assq :tangle (nth 4 block)))) - (file-name (org-babel-effective-tangled-filename - buffer-fn src-lang src-tfile)) - (by-fn (assoc file-name blocks))) - (if by-fn (setcdr by-fn (cons (cons src-lang block) (cdr by-fn))) - (push (cons file-name (list (cons src-lang block))) blocks))))))) + (dolist (block (org-babel-tangle-single-block counter t)) + (let ((src-file (car block)) + (src-lang (caadr block))) + (unless (or (not src-file) + ;; src block without lang + (and (not src-lang) src-file) + (and tangle-file (not (equal tangle-file src-file))) + ;; lang-re but either no lang or lang doesn't match + (and lang-re + (or (not src-lang) + (not (string-match-p lang-re src-lang))))) + (setq blocks + (mapcar (lambda (group) + (cons (car group) + (apply #'append (mapcar #'cdr (cdr group))))) + (seq-group-by #'car (push block blocks))))))))) ;; Ensure blocks are in the correct order. (mapcar (lambda (b) (cons (car b) (nreverse (cdr b)))) - (nreverse blocks)))) + (nreverse blocks)))) (defun org-babel-tangle--unbracketed-link (params) "Get a raw link to the src block at point, without brackets. @@ -541,6 +536,7 @@ The PARAMS are the 3rd element of the info for the same src block." (match-string 1 l)))) (when bare (if (and org-babel-tangle-use-relative-file-links + (stringp (cdr (assq :tangle params))) (string-match org-link-types-re bare) (string= (match-string 1 bare) "file")) (concat "file:" @@ -550,6 +546,38 @@ The PARAMS are the 3rd element of the info for the same src block." bare)))))) (defvar org-outline-regexp) ; defined in lisp/org.el + +(defun org-babel-tangle--concat-targets (buffer-fn info) + "Compute the list of target file paths for tangling a source block. +The BUFFER-FN is the absolute file name of the buffer, INFO the source + block information, as returned by `org-babel-get-src-block-info'." + (let* ((params (nth 2 info)) + (src-lang (nth 0 info)) + (src-tdirectories (cdr (assq :tangle-directory params))) + (src-tfiles (cdr (assq :tangle params)))) + (unless (or (not src-tdirectories) + (consp src-tdirectories)) + (setq src-tdirectories (list src-tdirectories))) + (unless (consp src-tfiles) + (setq src-tfiles + (list (cond ((string= src-tfiles "yes") + (file-name-nondirectory + (org-babel-effective-tangled-filename buffer-fn src-lang src-tfiles))) + ((string= src-tfiles "no") nil) + (t src-tfiles))))) + (when (and src-tdirectories + (not (equal src-tfiles '(nil)))) + (setq src-tfiles + (apply 'append + (mapcar (lambda (src-tdirectory) + (mapcar (lambda (src-tfile) + (expand-file-name src-tfile src-tdirectory)) + src-tfiles)) + src-tdirectories)))) + (mapcar (lambda (src-tfile) + (org-babel-effective-tangled-filename buffer-fn src-lang src-tfile)) + src-tfiles))) + (defun org-babel-tangle-single-block (block-counter &optional only-this-block) "Collect the tangled source for current block. Return the list of block attributes needed by @@ -580,7 +608,7 @@ non-nil, return the full association list to be used by ;; Run the tangle-body-hook. (let ((body (if (org-babel-noweb-p params :tangle) (if (string= "strip-tangle" (cdr (assq :noweb (nth 2 info)))) - (replace-regexp-in-string (org-babel-noweb-wrap) "" (nth 1 info)) + (replace-regexp-in-string (org-babel-noweb-wrap) "" (nth 1 info)) (org-babel-expand-noweb-references info)) (nth 1 info)))) (with-temp-buffer @@ -616,7 +644,6 @@ non-nil, return the full association list to be used by (match-end 0) (point-min)))) (point))))) - (src-tfile (cdr (assq :tangle params))) (result (list start-line (if org-babel-tangle-use-relative-file-links @@ -629,9 +656,10 @@ non-nil, return the full association list to be used by (org-trim (org-remove-indentation body))) comment))) (if only-this-block - (let* ((file-name (org-babel-effective-tangled-filename - file src-lang src-tfile))) - (list (cons file-name (list (cons src-lang result))))) + (let* ((file-names (org-babel-tangle--concat-targets file info))) + (mapcar (lambda (file-name) + (cons file-name (list (cons src-lang result)))) + file-names)) result))) (defun org-babel-tangle-comment-links (&optional info) diff --git a/testing/lisp/test-ob-tangle.el b/testing/lisp/test-ob-tangle.el index 4c953b15d..edcc04534 100644 --- a/testing/lisp/test-ob-tangle.el +++ b/testing/lisp/test-ob-tangle.el @@ -583,6 +583,14 @@ another block (set-buffer-modified-p nil)) (kill-buffer buffer)))) +(defun ob-tangle/tangle-targets () + "Return tangle targets for testing." + '("relative.el" "/tmp/absolute.el")) + +(defvar ob-tangle/tangle-targets + '("relative.el" "/tmp/absolute.el") + "Tangle targets variable for testing.") + (ert-deftest ob-tangle/collect-blocks () "Test block collection into groups for tangling." (org-test-with-temp-text-in-file "" ; filled below, it depends on temp file name @@ -632,6 +640,18 @@ another block \"H1: no language and inherited :tangle relative.el in properties\" #+end_src +#+begin_src emacs-lisp :tangle '(\"relative.el\" \"/tmp/absolute.el\") +\"H1: :tangle relative.el and /tmp/absolute.el\" +#+end_src + +#+begin_src emacs-lisp :tangle 'ob-tangle/tangle-targets +\"H1: :tangle relative.el and /tmp/absolute.el\" +#+end_src + +#+begin_src emacs-lisp :tangle (ob-tangle/tangle-targets) +\"H1: :tangle relative.el and /tmp/absolute.el\" +#+end_src + * H2 without :tangle in properties #+begin_src emacs-lisp @@ -668,7 +688,19 @@ another block #+begin_src \"H2: without language and thus without :tangle\" -#+end_src" +#+end_src + +* H3 with :tangle-directory + +#+begin_src emacs-lisp :tangle-directory /tmp/a :tangle '(\"foo.el\" \"bar.el\") :mkdirp yes +\"H3: :tangle /tmp/foo.el and /tmp/bar.el\" +#+end_src + +#+begin_src emacs-lisp :tangle-directory '(\"/tmp/a\" \"/tmp/b\") :tangle '(\"foo.el\" \"bar.el\") :mkdirp yes +\"H3: :tangle /tmp/a/foo.el, /tmp/a/bar.el, /tmp/b/foo.el and /tmp/b/bar.el\" +#+end_src + +" `((?a . ,el-file-abs) (?r . ,el-file-rel)))) ;; We check the collected blocks to tangle by counting equal @@ -691,10 +723,15 @@ another block ;; From `org-babel-tangle-collect-blocks'. collected-blocks))))) (should (equal (funcall normalize-expected-targets-alist - `(("/tmp/absolute.el" . 4) - ("relative.el" . 6) + `(("/tmp/absolute.el" . 7) + ("/tmp/a/foo.el" . 2) + ("/tmp/a/bar.el" . 2) + ("/tmp/b/foo.el" . 1) + ("/tmp/b/bar.el" . 1) + ("relative.el" . 8) ;; file name differs between tests - (,el-file-abs . 4))) + (,el-file-abs . 4) + )) (funcall count-blocks-in-target-files (org-babel-tangle-collect-blocks)))) ;; Simulate TARGET-FILE to test as `org-babel-tangle' and @@ -706,12 +743,16 @@ another block (list (cons :tangle el-file-abs))))) (should (equal (funcall normalize-expected-targets-alist - `(("/tmp/absolute.el" . 4) - ("relative.el" . 6) + `(("/tmp/absolute.el" . 7) + ("/tmp/a/foo.el" . 2) + ("/tmp/a/bar.el" . 2) + ("/tmp/b/foo.el" . 1) + ("/tmp/b/bar.el" . 1) + ("relative.el" . 8) ;; Default :tangle header now also ;; points to the file name derived from the name of - ;; the Org file, so 6 blocks should go there. - (,el-file-abs . 6))) + ;; the Org file, so 5 blocks should go there. + (,el-file-abs . 5))) (funcall count-blocks-in-target-files (org-babel-tangle-collect-blocks))))))))) -- 2.39.5 (Apple Git-154)