Commit `5bb13b8565`

5bb13b85656f8b0461eb4d7208602b9838ef3eb3

parent: 0153f33d98

Verified · cmc

cmc <hello@cleberg.net> · 2026-10-07 06:01 UTC

Tangle with Lisp header values and -l coderef formats

Header values written as Lisp are evaluated, with buffer-file-name,
default-directory, system-type and the file-name functions; other Lisp
is still refused. -r with -l "FORMAT" removes coderefs in that format.

Layout: unified · split

Sources/OrgCore/Compute/Tangle.swift +59 −11

		@@ -3,8 +3,8 @@ import Foundation
3	3	// `org-babel-tangle` (Org 9.8.7 ob-tangle.el): source blocks written to the files their
4	4	// `:tangle` names, with `:noweb`, `:padline`, `:shebang`, `:mkdirp`, `:tangle-mode`,
5	5	// `:prologue` and `:epilogue`, `:var` for shells, Python and Emacs Lisp, and `:comments` for
6		// languages whose comment syntax is known. Header values Org would evaluate as Lisp aren't
7		// supported.
	6	// languages whose comment syntax is known. Header values written as Lisp are evaluated with
	7	// the file's name and folder; other Lisp is refused.
8	8
9	9	public enum Tangle {
10	10	/// All blocks (C-c C-v t), the block at an offset (C-u C-c C-v t), or the blocks going to
		@@ -65,15 +65,15 @@ public enum Tangle {
65	65	switch scope {
66	66	case .block(let offset):
67	67	guard let block = block(at: offset, in: model) else { throw Babel.Failure.message("Point is not in a source code block") }
68		try add(block, try params(block, model: model, text: ns), counter: 1)
	68	try add(block, try params(block, model: model, text: ns, path: path), counter: 1)
69	69	case .all, .target:
70	70	var target: String?
71	71	if case .target(let offset) = scope {
72	72	guard let block = block(at: offset, in: model) else { throw Babel.Failure.message("Point is not in a source code block") }
73		target = try params(block, model: model, text: ns).single[":tangle"] ?? "no"
	73	target = try params(block, model: model, text: ns, path: path).single[":tangle"] ?? "no"
74	74	}
75	75	for block in model.srcBlocks where !excluded(block, model: model) {
76		let params = try params(block, model: model, text: ns)
	76	let params = try params(block, model: model, text: ns, path: path)
77	77	let tangle = params.single[":tangle"] ?? "no"
78	78	if tangle == "no" \|\| (block.language == nil && tangle == "yes") { continue }
79	79	if let target, target != tangle { continue }
		@@ -126,14 +126,58 @@ public enum Tangle {
126	126	}
127	127	}
128	128
129		static func params(_ block: SrcBlockInfo, model: DocumentModel, text: NSString) throws -> Babel.Params {
130		let params = try Babel.Params(block: block, model: model, text: text)
	129	static func params(_ block: SrcBlockInfo, model: DocumentModel, text: NSString, path: String) throws -> Babel.Params {
	130	var params = try Babel.Params(block: block, model: model, text: text)
131	131	for (key, value) in params.single where value.hasPrefix("(") && key != ":tangle-mode" {
132		throw Babel.Failure.message("\(key) \(value) is Lisp to evaluate, which tangling doesn't support yet; nothing was tangled.")
	132	params.single[key] = try evaluate(value, key: key, path: path)
133	133	}
134	134	return params
135	135	}
136	136
	137	/// `org-babel-read` of a header value written as Lisp, with what a file's buffer knows:
	138	/// `buffer-file-name`, `default-directory` and `system-type`.
	139	static func evaluate(_ value: String, key: String, path: String) throws -> String {
	140	let refusal = Babel.Failure.message("\(key) \(value) is Lisp tangling can't evaluate yet; nothing was tangled.")
	141	let lisp = Elisp()
	142	let directory = (path as NSString).deletingLastPathComponent + "/"
	143	lisp.set("buffer-file-name", .string(path))
	144	lisp.set("default-directory", .string(directory))
	145	lisp.set("system-type", .symbol("darwin"))
	146	func string(_ args: [Sexp], _ i: Int) throws -> String { try Elisp.string(args[i]) }
	147	lisp.define("expand-file-name") { lisp, args in
	148	try Elisp.arity(args, 1...2, "expand-file-name")
	149	let base = args.count > 1 && !Elisp.isNil(args[1]) ? try string(args, 1) : (try Elisp.string(lisp.value("default-directory")))
	150	return .string(expand(try string(args, 0), in: (base as NSString).expandingTildeInPath))
	151	}
	152	lisp.define("file-name-directory") { _, args in
	153	try Elisp.arity(args, 1...1, "file-name-directory")
	154	let name = try string(args, 0)
	155	guard let slash = name.lastIndex(of: "/") else { return .nil }
	156	return .string(String(name[...slash]))
	157	}
	158	lisp.define("file-name-nondirectory") { _, args in
	159	try Elisp.arity(args, 1...1, "file-name-nondirectory")
	160	let name = try string(args, 0)
	161	return .string(name.lastIndex(of: "/").map { String(name[name.index(after: $0)...]) } ?? name)
	162	}
	163	lisp.define("file-name-sans-extension") { _, args in
	164	try Elisp.arity(args, 1...1, "file-name-sans-extension")
	165	return .string((try string(args, 0) as NSString).deletingPathExtension)
	166	}
	167	lisp.define("file-name-as-directory") { _, args in
	168	try Elisp.arity(args, 1...1, "file-name-as-directory")
	169	let name = try string(args, 0)
	170	return .string(name.hasSuffix("/") ? name : name + "/")
	171	}
	172	guard let form = try? LispReader.readFirst(value).sexp, let result = try? lisp.eval(form), !Elisp.isNil(result) else { throw refusal }
	173	switch result {
	174	case .string(let s): return s
	175	case .symbol(let s): return s
	176	case .integer, .float: return Elisp.printed(result)
	177	default: throw refusal
	178	}
	179	}
	180
137	181	/// `org-babel-effective-tangled-filename`.
138	182	static func fileName(path: String, language: String?, tangle: String) throws -> String? {
139	183	let directory = (path as NSString).deletingLastPathComponent
		@@ -172,10 +216,14 @@ public enum Tangle {
172	216	body = try expandBody(body, language: block.language ?? "", params: params, model: model, text: text)
173	217	}
174	218	// `(string-match "-r" extra)`.
175		if block.switches.joined(separator: " ").contains("-r") {
176		if block.switches.contains("-l") { throw Babel.Failure.message("-l coderef formats aren't supported yet; nothing was tangled.") }
	219	let switches = block.switches.joined(separator: " ")
	220	if switches.contains("-r") {
	221	// `org-src-coderef-regexp` of `-l "FORMAT"`, or of `org-coderef-label-format`.
	222	let format = switches.firstMatch(of: /-l +"([^"\n]+)"/).map { String($0.1) } ?? "(ref:%s)"
	223	let pattern = "[ \\t]*" + NSRegularExpression.escapedPattern(for: format)
	224	.replacingOccurrences(of: "%s", with: "[-a-zA-Z0-9_][-a-zA-Z0-9_ ]") + "[ \\t]$"
177	225	body = body.components(separatedBy: "\n")
178		.map { $0.replacingOccurrences(of: "[ \\t]\$ref:[-a-zA-Z0-9_][-a-zA-Z0-9_ ]\$[ \\t]*$", with: "", options: .regularExpression) }
	226	.map { $0.replacingOccurrences(of: pattern, with: "", options: .regularExpression) }
179	227	.joined(separator: "\n")
180	228	}
181	229	let preserve = block.switches.contains("-i")

Tests/OrgCoreTests/TangleTests.swift +45 −1

		@@ -207,8 +207,52 @@ struct TangleTests {
207	207	#expect(Self.describe(ours, root: "/oracle") == theirs.text, "ours:\n\(Self.describe(ours, root: "/oracle"))\nemacs:\n\(theirs.text)\n\(theirs.error)")
208	208	}
209	209
	210	static let lisp = """
	211	#+begin_src sh :tangle (concat "joined" ".sh")
	212	echo joined
	213	#+end_src
	214	#+begin_src sh :tangle (if (eq system-type 'darwin) "mac.sh" "other.sh")
	215	echo mac
	216	#+end_src
	217	#+begin_src sh :tangle (concat (file-name-directory buffer-file-name) "beside.sh")
	218	echo beside
	219	#+end_src
	220	#+begin_src sh :tangle (expand-file-name "sub/deep.sh") :mkdirp yes
	221	echo deep
	222	#+end_src
	223	#+begin_src sh :tangle (file-name-sans-extension (file-name-nondirectory buffer-file-name))
	224	echo named after the file
	225	#+end_src
	226	#+begin_src python -r -l "#(ref:%s)" :tangle refs.py
	227	x = 1 #(ref:one)
	228	y = 2 (ref:kept)
	229	#+end_src
	230	#+begin_src python -r :tangle refs.py
	231	z = 3 (ref:gone)
	232	#+end_src
	233	""" + "\n"
	234
	235	@Test func evaluatesLispHeadersLikeOrg() throws {
	236	let form = """
	237	(let* ((dir (file-truename (make-temp-file "orgstar-tangle" t)))
	238	(src (expand-file-name "notes.org" dir))
	239	(text (buffer-string)) out)
	240	(require 'ob-shell) (require 'ob-python)
	241	(with-temp-file src (insert text))
	242	(with-current-buffer (find-file-noselect src)
	243	(let ((files (org-babel-tangle)))
	244	(setq out (mapconcat (lambda (f) (format "== %s %o\\n%s" (file-relative-name f dir) (file-modes f)
	245	(with-temp-buffer (insert-file-contents f) (buffer-string))))
	246	(sort (copy-sequence files) #'string<) ""))))
	247	(erase-buffer) (insert out))
	248	"""
	249	let theirs = try EmacsOracle.run([EmacsOracle.Case(text: Self.lisp, point: 1, form: form)])[0]
	250	let ours = try Tangle.run(text: Self.lisp, path: "/oracle/notes.org").get()
	251	#expect(Self.describe(ours, root: "/oracle") == theirs.text, "ours:\n\(Self.describe(ours, root: "/oracle"))\nemacs:\n\(theirs.text)\n\(theirs.error)")
	252	}
	253
210	254	@Test func refusesWhatItCantDo() {
211		for (language, header) in [("haskell", ":comments link"), ("sh", ":tangle (concat \"a\" \".sh\")"), ("sh", ":tangle-mode go+q")] {
	255	for (language, header) in [("haskell", ":comments link"), ("sh", ":tangle (concat user-emacs-directory \"a.sh\")"), ("sh", ":tangle-mode go+q")] {
212	256	let text = "#+begin_src \(language) :tangle yes \(header)\necho\n#+end_src\n"
213	257	guard case .failure = Tangle.run(text: text, path: "/x/a.org") else { Issue.record("tangled with \(header)"); continue }
214	258	}

Commit 5bb13b8565

Commit `5bb13b8565`