:2025-06-20-22-12:
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:
:2025-06-20-22-01:
除了 search-option 外，我们还提供一种缩写机制，将 http[s]:///ABBR//xxx
改写为 http[s]://long/url/string/xxx
定义缩写的方式为：
#+begin_src emacs-lisp :eval no
(cl-macrolet
((defabbr (abbr full)
`(setf (alist-get
,abbr (get 'org-noweb-expand-link
'http-abbr))
,full)))
(defabbr "ABBR" "long/url/string"))
#+end_src
:end:
browse-url 新增 HTTP 缩写特性。
#+name: elisp-2025-06-20-16-41
#+begin_src emacs-lisp :eval no :noweb yes
;; <<@([[:2025-06-20-22-12:]])>>
((lambda (parse-url)
(lambda (url &rest args)
(let* ((url (funcall parse-url url))
(start (float-time))
(timeout 10)
(done nil)
(hook (lambda () (setq done t)))
;; shr-tag-pre 会自动加空行，影响格式。
;; 这里，我们重新定义其渲染函数。
(shr-external-rendering-functions
(append
shr-external-rendering-functions
`((pre . ,(lambda (dom)
(let ((shr-folding-mode 'none)
(shr-current-font 'default))
(shr-generic dom)))))))
;; shr-bullet 默认为 "* ", 会呈现为
;; Org Headline, 这里我们改用 "- ".
(shr-bullet "- "))
(add-hook 'eww-after-render-hook hook)
(eww-browse-url (plist-get url :url))
(while (and (not done) (< (- (float-time) start) timeout))
(sit-for 1))
(remove-hook 'eww-after-render-hook hook)
(eww-readable 1)
(if (not done)
(error "eww browse url %S timeout" (plist-get url :url))
(when (plist-get url :search-option)
(org-mode)
(org-link-search (plist-get url :search-option)))))))
;; parse-url
;; <<@([[:2025-06-20-22-01:]])>>
(lambda (url)
(let* ((full nil) (abbr nil)
(abbr-map (get 'org-noweb-expand-link 'http-abbr)))
(save-match-data
(when (string-match "http[s]://\\(/[^/]+/\\)" url)
(setq abbr (substring (match-string 1 url) 1 -1))
(setq full (alist-get abbr abbr-map nil nil #'string=))
(unless full (error "Invalid abbr: %s" abbr))
(setq url (replace-match full nil t url 1)))))
(let* ((parsed-url `(:origin-url ,url))
(url (string-split url "::"))
(search-option (if (length> url 1) (car (last url))))
(url (if (null search-option)
(car url)
(string-join (nbutlast url) "::")))
(full nil) (abbr nil)
(abbr-map (get 'org-noweb-expand-link 'http-abbr)))
(plist-put parsed-url :url url)
(plist-put parsed-url :search-option search-option)
parsed-url)))
#+end_src
未变更部分。
#+name: elisp-2025-06-20-21-35
#+header: :tangle ~/org/archived/tangle/org-noweb.el
#+begin_src emacs-lisp :eval yes :lexical t :results silent :noweb yes
;;; 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))))
;; 正常来说，我们是不需要 remove-hook 的，尽管会让 tangle-hook 里多些东西。
;; 但当本模块本重复执行时, add-hook 不能正常识别我们的 hook. 所以，这里加
;; 这两句 remove-hook. 虽然但是，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
<<elisp-2025-06-20-16-41>>))
#+end_src
