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	// `org-babel-tangle` (Org 9.8.7 ob-tangle.el): source blocks written to the files their	3	// `org-babel-tangle` (Org 9.8.7 ob-tangle.el): source blocks written to the files their
4	// `:tangle` names, with `:noweb`, `:padline`, `:shebang`, `:mkdirp`, `:tangle-mode`,	4	// `:tangle` names, with `:noweb`, `:padline`, `:shebang`, `:mkdirp`, `:tangle-mode`,
5	// `:prologue` and `:epilogue`, `:var` for shells, Python and Emacs Lisp, and `:comments` for	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	6	// languages whose comment syntax is known. Header values written as Lisp are evaluated with
7	// supported.	7	// the file's name and folder; other Lisp is refused.
8		8
9	public enum Tangle {	9	public enum Tangle {
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	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	switch scope {	65	switch scope {
66	case .block(let offset):	66	case .block(let offset):
67	guard let block = block(at: offset, in: model) else { throw Babel.Failure.message("Point is not in a source code block") }	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	case .all, .target:	69	case .all, .target:
70	var target: String?	70	var target: String?
71	if case .target(let offset) = scope {	71	if case .target(let offset) = scope {
72	guard let block = block(at: offset, in: model) else { throw Babel.Failure.message("Point is not in a source code block") }	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	for block in model.srcBlocks where !excluded(block, model: model) {	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	let tangle = params.single[":tangle"] ?? "no"	77	let tangle = params.single[":tangle"] ?? "no"
78	if tangle == "no" \|\| (block.language == nil && tangle == "yes") { continue }	78	if tangle == "no" \|\| (block.language == nil && tangle == "yes") { continue }
79	if let target, target != tangle { continue }	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 {	129	static func params(_ block: SrcBlockInfo, model: DocumentModel, text: NSString, path: String) throws -> Babel.Params {
130	let params = try Babel.Params(block: block, model: model, text: text)	130	var params = try Babel.Params(block: block, model: model, text: text)
131	for (key, value) in params.single where value.hasPrefix("(") && key != ":tangle-mode" {	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	return params	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	/// `org-babel-effective-tangled-filename`.	181	/// `org-babel-effective-tangled-filename`.
138	static func fileName(path: String, language: String?, tangle: String) throws -> String? {	182	static func fileName(path: String, language: String?, tangle: String) throws -> String? {
139	let directory = (path as NSString).deletingLastPathComponent	183	let directory = (path as NSString).deletingLastPathComponent
	@@ -172,10 +216,14 @@ public enum Tangle {
172	body = try expandBody(body, language: block.language ?? "", params: params, model: model, text: text)	216	body = try expandBody(body, language: block.language ?? "", params: params, model: model, text: text)
173	}	217	}
174	// `(string-match "-r" extra)`.	218	// `(string-match "-r" extra)`.
175	if block.switches.joined(separator: " ").contains("-r") {	219	let switches = block.switches.joined(separator: " ")
176	if block.switches.contains("-l") { throw Babel.Failure.message("-l coderef formats aren't supported yet; nothing was tangled.") }	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	body = body.components(separatedBy: "\n")	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	.joined(separator: "\n")	227	.joined(separator: "\n")
180	}	228	}
181	let preserve = block.switches.contains("-i")	229	let preserve = block.switches.contains("-i")

Tests/OrgCoreTests/TangleTests.swift +45 −1

	@@ -207,8 +207,52 @@ struct TangleTests {
207	#expect(Self.describe(ours, root: "/oracle") == theirs.text, "ours:\n\(Self.describe(ours, root: "/oracle"))\nemacs:\n\(theirs.text)\n\(theirs.error)")	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	@Test func refusesWhatItCantDo() {	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	let text = "#+begin_src \(language) :tangle yes \(header)\necho\n#+end_src\n"	256	let text = "#+begin_src \(language) :tangle yes \(header)\necho\n#+end_src\n"
213	guard case .failure = Tangle.run(text: text, path: "/x/a.org") else { Issue.record("tangled with \(header)"); continue }	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`