From c53813ba9a1f1ac502af11734c565004419572be Mon Sep 17 00:00:00 2001 From: llcc Date: Fri, 4 Apr 2025 20:47:11 +0800 Subject: [PATCH] New feature: tangle org source blocks to multiple targets 1. add `:tangle-directory' to specify tangle directory. 2. `:tangle' now accepts symbols that return a path string, or a list of file path, or a single string. --- lisp/ob-tangle.el | 83 ++++++++++++++++++++++++---------- testing/lisp/test-ob-tangle.el | 53 +++++++++++++++++++--- 2 files changed, 105 insertions(+), 31 deletions(-) diff --git a/lisp/ob-tangle.el b/lisp/ob-tangle.el index 38cad78ab..d721d45fc 100644 --- a/lisp/ob-tangle.el +++ b/lisp/ob-tangle.el @@ -500,34 +500,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") + (let* ((block (org-babel-tangle-single-block counter t)) + (src-file (car block)) + (src-lang (caar block))) + (unless (or (not src-file) ;; src block without lang - (and (not src-lang) (string= src-tfile "yes")) - (and tangle-file (not (equal tangle-file src-tfile))) + (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 + (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))))))) + (setq blocks + (mapcar (lambda (group) + (cons (car group) + (apply #'append (mapcar #'cdr (cdr group))))) + (seq-group-by #'car (append 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 +537,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 +547,42 @@ 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) + "Return a list of tangled files based on the `:tangle' +and `:tangle-directory' in PARAMS." + (let* ((params (nth 2 info)) + (src-lang (nth 0 info)) + (src-tdirectories (cdr (assq :tangle-directory params))) + (src-tfiles (cdr (assq :tangle params))) + (src-tfiles (pcase (type-of src-tfiles) + ('cons src-tfiles) + ('symbol (eval src-tfiles)) + (_ (eval src-tfiles))))) + (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))))) + (remove nil 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 +613,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 +649,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 +661,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..d7fec0110 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" . 9) ;; 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,8 +743,12 @@ 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" . 9) ;; Default :tangle header now also ;; points to the file name derived from the name of ;; the Org file, so 6 blocks should go there. -- 2.39.5 (Apple Git-154)