Org Tangle 扩展。
#+begin_src emacs-lisp :eval no
<<@(org-link)>>
#+end_src
特性：基于 Org ID 链接；条件 Tangle; Outline 调节；文本 Tangle; HTTP Tangle.
1 基于 Org ID 链接
配合 org-open-at-point-global 使用，方便打开代码块中的 <<@(link)>>.
2 条件 Tangle
考虑不同平台的键绑定配置：
#+name: android-2025-06-16-17-00
#+begin_src emacs-lisp :expand (eq system-type 'android) :eval no
(defkey "c i" #'open-init.el)
#+end_src
#+name: window-2025-06-16-17-00
#+begin_src emacs-lisp :expand (eq system-type 'windows-nt) :eval no
(defkey "C-c i" #'open-init.el)
#+end_src
#+begin_src emacs-lisp :tangle ~/org/a.txt :eval no
(keymap-setting platform
<<@([[id:977ba407-14a4-48c9-a0d4-947ea0e8686f::window-2025-06-16-17-00]])>>
<<@([[id:977ba407-14a4-48c9-a0d4-947ea0e8686f::android-2025-06-16-17-00]])>>)
#+end_src
Window 上的 tangle 结果：
(keymap-setting platform
(defkey "C-c i" #'open-init.el)
)
Android 上的 tangle 结果（自动删除展开为空的行）：
(keymap-setting platform
(defkey "c i" #'open-init.el))
3 Outline 调节
通过 <<@(link, level)>>，将展开后的代码片段的 Outline 等级 demote 至 level.
给定如下两个片段：
#+name: section-2025-06-16-17-01
#+begin_src emacs-lisp :tangle ~/org/a.txt :eval no
;;; Level 1
(ignore "section")
<<@([[id:977ba407-14a4-48c9-a0d4-947ea0e8686f::subsection-2025-06-16-17-01]],2)>>
#+end_src
#+name: subsection-2025-06-16-17-01
#+begin_src emacs-lisp :eval no
;;; Level 2
(ignore "subsection")
;;;; Level 3
(ignore "subsubsection")
#+end_src
展开为：
;;; Level 1
(ignore "section")
;;;; Level 2
(ignore "subsection")
;;;;; Level 3
(ignore "subsubsection")
4 文本 Tangle
基于 Org Link Search Option, tangle drawer block, paragraph 等文本。
给定如下 drawer:
:doc-2025-06-16-17-15:
browse-url
借助 eww 将 url 指定的资源渲染为纯文本，当前主要针对 http/https.
由于 Org link 的语法不支持定位 http/https 中的文本块，这里，我们
仿照 Org file/id link, 借助 `org-link-search', 为 http/https
链接提供一个定位文本块用的 search-option, 以如下形式：
`url::search-option'
如此，我们便可用 [[http://host/path-to-file...::search-option]]
获取网络中的 Org 文本块。
:end:
片段
#+begin_src emacs-lisp :tangle ~/org/a.txt :eval no
;; <<@([[id:977ba407-14a4-48c9-a0d4-947ea0e8686f:::doc-2025-06-16-17-15:]])>>
(lambda (url &rest args)
...)
#+end_src
展开为：（见下小节）
5 HTTP Tangle
从 HTTP/HTTPS 指向的资源中 tangle 文本块。
;; browse-url
;;
;; 借助 eww 将 url 指定的资源渲染为纯文本，当前主要针对 http/https.
;; 由于 Org link 的语法不支持定位 http/https 中的文本块，这里，我们
;; 仿照 Org file/id link, 借助 `org-link-search', 为 http/https
;; 链接提供一个定位文本块用的 search-option, 以如下形式：
;;
;; `url::search-option'
;;
;; 如此，我们便可用 [[http://host/path-to-file...::search-option]]
;; 获取网络中的 Org 文本块。
(lambda (url &rest args)
...)
配合 url-cache 使用。
一个例子：
#+begin_src emacs-lisp :tangle ~/org/a.txt :eval no
<<@([[https://emacs-china.org/t/org-include-url/29242/24::elisp-2025-03-26-17-50]])>>
#+end_src
展开为：
(unless (assoc 'expand org-babel-library-of-babel)
(with-temp-buffer
(org-mode)
(insert
"#+name: expand\n"
"#+begin_src emacs-lisp\n"
"(org-babel--src-block\n"
" (if (boundp 'there) there) (if (boundp 'name) name) nil t)\n"
"#+end_src")
(org-babel-lob-ingest)))
6 实现
#+name: elisp-2025-06-16-11-01
#+begin_src emacs-lisp :lexical t :results silent
;;; Org Noweb Expand Link -*- lexical-binding: t; -*-
;;;; org-noweb-expand-link
(defalias 'org-noweb-expand-link
((lambda (locate expand _log _outline-adjust browse-url)
;; 注册 org-babel 函数 @
(with-temp-buffer
(org-mode)
(message "org-noweb register org babel function: @")
(let* ((vars `((level (ignore)) (par (ignore))
(src (ignore)) (re (ignore))
(drw (ignore))))
(ha (mapconcat
(lambda (v) (format ":var %s=%s" (car v) (cadr v))) vars " "))
(a (mapconcat
(lambda (v) (format ":%s %s" (car v) (car v))) vars " ")))
(insert
"#+name: @\n"
"#+begin_src emacs-lisp :var link=\"\" " ha "\n"
"(org-noweb-expand-link (format \"%s\" link) " a ")\n"
"#+end_src")
(org-babel-lob-ingest)))
;; `org-noweb-expand-link' 函数入口
(lambda (link &rest conf)
;; 调试用
(let ((tsfmt "[%Y-%m-%d %H:%M:%S.%3N]"))
(princ (format "%s %s\n"
(format-time-string tsfmt (current-time)) link)
(get-buffer-create "*Org Noweb*")))
(defvar log)
(defvar outline-adjust)
(let ((log _log)
(outline-adjust _outline-adjust)
(marker (funcall locate link browse-url)))
(if (null marker)
(funcall log "failed to expand %s." link)
(org-with-point-at marker
(funcall expand conf))))))
;;;; 内部接口
;;;;; locate
;; 尽可能地借 `org-link-open' 定位 link 所指定的位置。
(lambda (link browse-url)
"返回 link 所指向的位置，以 marker 形式。"
(save-window-excursion
(ignore-errors
(let ((org-link-frame-setup `((file . find-file)
,@org-link-frame-setup))
(inhibit-message t)
(message-log-max nil)
;; 使能 text search.
(org-link-search-must-match-exact-headline nil)
;; 这里，我们提供一个配置变量 `org-noweb-browse-url'，以便
;; 有用户出于某种目的想定制自己的browse-url 函数。比如，为了
;; 缓存 url 指定的数据。
(browse-url-browser-function
(or (and (boundp 'org-noweb-browse-url) org-noweb-browse-url)
browse-url)))
(if (stringp link)
(org-link-open-from-string link)
(org-link-open link)))
(setq marker (make-marker))
(set-marker marker (point)))))
;;;;; expand
(lambda (conf)
"展开位于当前 buffer 当前 point 位置的 Org element."
(let* ((ele (org-element-at-point))
(type (org-element-type ele))
(par (plist-get conf :par))
(drw (plist-get conf :drw)))
(cond
;; 展开代码块
((eq type 'src-block)
(let* ((info (org-babel-get-src-block-info))
(body ""))
;; 如果代码块参数 `:expand' 的 sexp 求值
;; 为 nil，
(if (and (assq :expand (nth 2 info))
(not (alist-get :expand (nth 2 info))))
;; 表明该代码块在当前环境下拒绝展开。
(funcall log "ignore %s." link)
;; 展开代码块
(setq body (org-babel-expand-noweb-references info))
;; 调整 outline
(setq body (funcall outline-adjust
body (nth 0 info) (plist-get conf :level)))
body)))
;; 展开 drawer
((eq type 'drawer)
(string-trim
(buffer-substring
(org-element-contents-begin ele)
(org-element-contents-end ele))))
;; 展开当前段落
((eq type 'paragraph)
(org-with-wide-buffer
(org-narrow-to-element)
(string-trim (buffer-string))))
;; 展开注释块
((eq type 'comment-block)
(string-trim (org-element-property :value ele)))
;; 除 link 提供的接口外，在下面的 case 中，我们通过 conf 参数提供一些
;; 额外定位 element 的手段，但不建议使用。
;; 展开指定段落文本
((and (eq type 'headline) par (> par 0))
(org-with-wide-buffer
(org-narrow-to-subtree)
(catch 'break
(org-element-map (org-element-parse-buffer nil t t)
'(paragraph)
(lambda (p)
(setq par (1- par))
(when (= par 0)
(setq par (org-element-interpret-data p))
(throw 'break (string-trim par))))))))
;; 展开 drawer 中的文本
((and (eq type 'headline) drw)
(org-with-wide-buffer
(org-narrow-to-subtree)
(catch 'break
(org-element-map (org-element-parse-buffer nil t t)
'(drawer)
(lambda (d)
(when (string= (org-element-property :drawer-name d) drw)
(setq drw (string-trim
(buffer-substring
(org-element-contents-begin d)
(org-element-contents-end d))))
(throw 'break drw)))))))
;; 未定义
(t (funcall log "%s point to an unsupported position." link)))))
;;;;; log
;; 这个函数有两个作用：
;; 一、将 msg 输出为 warning, 以便用户知道哪些 link 展开失败；
;; 二、将 msg 作为展开失败时的展开结果，即，如果给定 link 展开失败，
;; 将 msg 作为该 link 的展开结果，此时, msg 作为非法字符串，最终
;; 由 remove-log 从 tangle 出的文件中移除。
(letrec ((tangling nil)
(remove-log
(lambda ()
(save-excursion
(let* ((zw-spc (char-to-string ?\u200B))
(re (concat zw-spc "org-noweb-expand-link .*" zw-spc))
(re (format "^\\(.*\\)\\(%s\\)\\(\n?\\)" re)))
(save-match-data
(goto-char (point-min))
(while (re-search-forward re nil t)
(if (and (length= (string-trim (match-string 1)) 0)
(length= (match-string 3) 1))
(replace-match "")
(replace-match "" nil nil nil 2))))))
(remove-hook 'org-babel-tangle-body-hook remove-log))))
;; 虽然但是, it works.
(remove-hook 'org-babel-pre-tangle-hook (lambda () (setq tangling t)))
(remove-hook 'org-babel-post-tangle-hook (lambda () (setq tangling nil)))
(add-hook 'org-babel-pre-tangle-hook (lambda () (setq tangling t)))
(add-hook 'org-babel-post-tangle-hook (lambda () (setq tangling nil)))
(lambda (fmt &rest args)
(add-hook 'org-babel-tangle-body-hook remove-log)
(let* ((msg (apply #'format fmt args))
(zw-spc (char-to-string ?\u200B))
;; 用零宽空格及 org-noweb-expand-link 界定非法字符串。
(msg (concat zw-spc "org-noweb-expand-link " msg zw-spc)))
(display-warning 'org-noweb msg :warning)
(if tangling msg ""))))
;;;;; outline-adjust
;; 根据 lang 调节 body 中的 outline。具体实现交由
;; `org-noweb-demote:LANG' 处理。这里只提供一个针对 emacs-lisp 的默
;; 认调整函数。
((lambda (org-noweb-demote-emacs-lisp)
(lambda (body lang level)
"将 body 中所有 level 1 的 outline 及其子树 demote 至 level `LEVEL'."
(or
(when-let*
((_ (and level (> level 1)))
(major-mode (org-src-get-lang-mode lang))
(demote (string-trim-right
(format "org-noweb-demote:%s" major-mode) "-mode"))
(demote (intern demote))
(demote (or (and (functionp demote) demote)
(and (eq demote 'org-noweb-demote:emacs-lisp)
org-noweb-demote-emacs-lisp))))
(ignore-errors
(with-temp-buffer
(outline-mode)
(save-excursion (insert body))
(funcall demote level)
(buffer-string))))
body)))
;; 提供一个调节 emacs-lisp outline 的默认函数。
(lambda (level)
(let ((outline-regexp ";;\\(;\\)\\{1,20\\} ")
(outline-heading-alist
(mapcar
(lambda (n) `(,(concat (make-string (+ 2 n) ?\;) " ") . ,n))
(number-sequence 1 20))))
(save-excursion
(outline-map-region
(lambda () (dotimes (_ (1- level)) (outline-demote nil)))
(point-min) (point-max))))))
;;;;; browse-url
;; 借助 eww 将 url 指定的资源渲染为纯文本，当前主要针对 http/https.
;; 由于 Org link 的语法不支持定位 http/https 中的文本块，这里，我们
;; 仿照 Org file/id link, 借助 `org-link-search', 为 http/https
;; 链接提供一个定位文本块用的 search-option, 以如下形式：
;;
;; `url::search-option'
;;
;; 如此，我们便可用 [[http://host/path-to-file...::search-option]]
;; 获取网络中的 Org 文本块。
(lambda (url &rest args)
(let* ((url (string-split url "::"))
(search-option (if (length> url 1) (car (last url))))
(url (if (null search-option)
(car url)
;; 移除 search-option.
(setf (nthcdr (1- (length url)) url) nil)
(string-join url "::")))
;; (eww-retrieve-command 'sync)
(timeout 10)
(done nil)
(hook (lambda () (setq done t))))
(add-hook 'eww-after-render-hook hook)
(eww-browse-url url)
(while (and (> timeout 0) (not done))
(sit-for 1)
(setf timeout (1- timeout)))
(remove-hook 'eww-after-render-hook hook)
(if (= timeout 0)
(error "eww browse url %S timeout" url)
(when search-option
(org-mode)
(org-link-search search-option)))))))
#+end_src
