Release 2025-08-23-21-55, 非最新版本。
By:
(org-exec "[[https://emacs-china.org/t/org/29965/31::2025-08-23-11-31]]")
;;; -*- lexical-binding: t; -*-
;;; Code:
;; dependencies
(require 'seq)
(require 'cl-lib)
(require 'cl-macs)
(require 'org)
(require 'org-clock)
(defmacro !let (bindings &rest body)
(declare
(indent
(lambda (p s)
(save-excursion
(goto-char (car (last (nth 9 s))))
(1+ (current-column))))))
(cond
((null bindings) `(progn ,@body))
(t
(let (vars vals)
(mapc
(lambda (binding)
(push (or (car-safe binding) binding) vars)
(push (car (cdr-safe binding)) vals))
bindings)
(setq vars (nreverse vars))
(setq vals (nreverse vals))
`(funcall
(lambda (,@vars)
(cl-macrolet
,(mapcar
(lambda (s)
`(,s (&rest args)
`(funcall
;;,',s
(or (and (functionp ,',s) ,',s)
(function ,',s))
,@args)))
vars)
,@body))
,@vals)))))
(defmacro !let* (bindings &rest body)
(declare
(indent
(lambda (p s)
(save-excursion
(goto-char (car (last (nth 9 s))))
(1+ (current-column))))))
(if (null bindings) `(progn ,@body)
(setq bindings (reverse bindings))
(while bindings
(setq body (list `(!let (,(pop bindings))
,@body))))
(car body)))
(defmacro !def (sym val)
(declare
(indent
(lambda (p s)
(save-excursion
(goto-char (car (last (nth 9 s))))
(1+ (current-column))))))
`(!let ((val ,val))
(if (ignore-errors
(and ,sym (symbolp ,sym) (functionp val)))
(defalias ,sym val)
(setq ,sym val))))
;;; org-referent-get -*- lexical-binding: t; -*-
(!def 'org-referent-get
;;;; private
(!let (org-referent-get
do-cmd do-conf
cache update-cache reset-cache
get-cache put-cache get-prop
bind-value compute-value
add-dependent setup-dependencies
invalidate-dependent
(locate (make-symbol "locate"))
(log (lambda (&rest _))))
;;;; org-referent-get
(put 'org-referent-get 'lisp-indent-function 'defun)
(!def org-referent-get
(lambda (&optional link property &rest kargs)
"Org (Link) Referent Property.
定位并跳转到链接 LINK 所指位置，于该处获取属性 PROPERTY
的属性值并缓存备用。
LINK 通常为 string. PROPERTY 可以是 string, lambda,
symbol, nil.
LINK 为 string 时表示一条 Org链接，如 “id:x”,
“[[id:x]]”; 其他情况见后续。
PROPERTY 为 string 时, ‘org-referent-get’ 通过
(org-entry-get nil PROPERTY) 获取属性值，支持缓存；
PROPERTY 为 lambda 时, ‘org-referent-get’ 通过
(funcall PROPERTY) 获取属性值，不支持缓存；
PROPERTY 为 symbol 时, ‘org-referent-get’ 通过
(funcall PROPERTY) 获取属性值，支持缓存。
若 PROPERTY symbol 有 \\='org-referent-get-base 属性
(后简称 base), base 可以是另一个 property, 或一个
无参lambda, PROPERTY 将通过该 base 获取其属性值。
KARGS
:epom 所指位置，默认 nil.
:force 强制更新缓存标志，默认 nil.
:no-cache 禁用缓存标志，默认 nil.
:base 将属性值绑定至 BASE 属性值，默认 nil.
:depends 设置属性依赖项，默认 nil.
:apply 启用间接属性值，默认 nil.
‘org-referent-get’涉及链接定位、属性取值、属性值缓存。
通过 LINK 及 某些 KARGS 可控制其执行行为，具体如下表
所示 (配置的优先及由高到低排列，PROPERTY 非 nil):
LINK :epom :force :no-cache
non-nil non-nil _ _ 取值/缓存
nil non-nil _ _ 取值
non-nil nil nil nil 取缓存值
non-nil nil t nil 定位/取值/缓存
non-nil nil _ t 定位/取值
nil nil _ _ 取值
其中，‘_’表示忽略该标志。
取值：于当前位置，通过 PROPERTY, 取属性值。
定位：定位并跳转至 LINK 所指位置（费时操作）。
缓存：缓存所取属性值。
返回值及其他用法
正常情况下，返回 LINK 合 PROPERTY 所指的属性值；但根据
输入参数的状态，还可细分：属性配置；缓存更新与重置；命令模
式等用法，有区别于返回属性值。
属性配置
(org-referent-get \\='set P0 :base P1)
=> 使 P0 基于 P1, P0 属性缓存值的将与 P1 保持同步。
(org-referent-get \\='set P0 :depends \\='(P1 ...))
=> 使 P0 依赖 P1 等，任一属性的变化将导致 P0 缓存失效。
(org-referent-get \\='set P0 :apply t)
=> 使 P0 为间接属性值，其属性值的调用返回值将作为属性值。
缓存更新与重置
(org-referent-get LINK)
=> 返回 LINK 所有属性 PROPERTY.
(org-referent-get LINK nil :force t)
=> 强制更新 LINK 所有的属性缓存值。
(org-referent-get LINK nil :no-cache t)
=> 删除 LINK 所有的属性缓存值。
(org-referent-get nil nil :force t)
=> 强制更新所有的属性缓存值。
(org-referent-get nil nil :no-cache t)
=> 重置所有的属性缓存值。
其他
M-x org-referent-get => 命令模式
(org-referent-get) => 返回内部缓存用的哈希表。"
(interactive)
(cond
;; 缓存控制及命令模式
((and (null link) (null property))
(cond
((plist-get kargs :force) (update-cache))
((plist-get kargs :no-cache) (reset-cache))
((called-interactively-p 'interactively)
(do-cmd))
(t cache)))
;; 单条 LINK 的缓存控制
((null property)
(cond
((plist-get kargs :force)
(update-cache `(,link)))
((plist-get kargs :no-cache)
(reset-cache `(,link)))
((and-let* ((hash (gethash link cache)))
(hash-table-keys hash)))))
;; 控制命令
((and link (symbolp link))
(apply do-conf link property kargs))
((ignore
(when (or (not (or (symbolp property)
(stringp property)))
(null link))
(plist-put kargs :no-cache t))))
;; 获取属性值
((or (plist-get kargs :epom)
(plist-get kargs :no-cache))
(log "link: %s\n kargs: %S" link kargs)
(!let ((v (apply get-prop link property kargs)))
(setq v (compute-value property v))
(log " %S value: %S" property v)
v))
;; 获取属性缓存值
((!let* ((P (or (gethash link cache)
(make-hash-table :test #'equal)))
(C (get-cache link property t))
(v (car (last C))))
(log "link: %s\n kargs: %S" link kargs)
(when (or (null C) (plist-get kargs :force))
(setq v (apply get-prop link property kargs)))
(setq v (compute-value property v))
(log " %S value: %S" property v)
v)))))
;;;; do-cmd
(!def do-cmd
;; depends: reset-cache, update-cache.
(lambda ()
(let ((choices
'((?r "reset" "reset all cache")
(?d "delete" "delete a cache entry")
(?u "update" "update all cache")))
link)
(pcase (car (read-multiple-choice "?" choices))
(?r (reset-cache))
(?u (update-cache))
(?d (setq link (read-string "Link: "))
(when (length> link 0)
(reset-cache `(,link))))))))
;;;; do-conf
(!def do-conf
;; depends: log.
(lambda (op property &rest kargs)
(pcase op
('set
(when (symbolp property)
(when (plist-get kargs :base)
(put property 'org-referent-get-base
(plist-get kargs :base))
(log "%s base %s" property
(plist-get kargs :base)))
(when (plist-get kargs :depends)
(put property 'org-referent-get-depends
(plist-get kargs :depends))
(log "%s depends %s" property
(plist-get kargs :depends)))
(when (plist-get kargs :apply)
(put property 'org-referent-get-apply
(plist-get kargs :apply))
(log "%s apply %s" property
(plist-get kargs :apply))))))))
;;;; update-cache
(!def update-cache
;; depends: cache, get-prop.
(lambda (&optional links)
(!let* ((L links)
(L (or L (hash-table-keys cache)))
(N (length L)) (Np 0) (i 0)
(T #'float-time) (Ts (T)))
(dolist (l L)
(message
"Updating cache (%d/%d): %s, %ds"
(setf i (1+ i)) N l (- (T) Ts))
(and-let* ((P (gethash l cache))
(P (hash-table-keys P)))
(dolist (p P)
(setf Np (1+ Np))
(get-prop l p :force t))))
(message
(concat
"%d links %d properties cache updated, "
"time cost: %ds.")
N Np (- (T) Ts)))))
;;;; reset-cache
(!def reset-cache
;; depends: cache.
(lambda (&optional links)
(cond
(links
(dolist (l links)
(remhash l cache)
(message "link: %s cache deleted." l)))
(t (clrhash cache)
(message "All cache reset.")))))
;;;; get-cache
(!def get-cache
;; depends: cache
(lambda (link property &optional all)
;; 缓存项 C 的结构: (flag dependent value)
;; flag: t/nil, 表示是否有初始化。
;; dependent: symbol 类 property 集。
;; value: 属性缓存值，可用 (last cache) 共享。
(and-let* ((P (gethash link cache))
(C (gethash property P))
(v (if all C (car (last C))))))))
;;;; put-cache
(!def put-cache
;; depends: cache, invalidate-dependent, log.
(lambda (link property value)
(when (and (or (stringp property)
(symbolp property))
link)
(log " %S update" property)
(!let* ((P (or (gethash link cache)
(puthash link (make-hash-table
:test #'equal)
cache)))
(C (or (gethash property P)
`(nil nil ,value))))
(cond
;; 引用保持。
((car C)
(unless (equal (car (last C)) value)
(setf (car (last C)) value)
(invalidate-dependent link property)))
;; 缓存初始化。
((setf (car C) t)
(puthash property C P)))))
value))
;;;; get-prop
(!def get-prop
;; self: get-prop
;; depends: put-cache, locate, bind-value,
;; setup-dependencies, log.
(lambda (link prop &rest kargs)
(!let ((no-cache (or (plist-get kargs :no-cache)
(null link)))
(P prop) (L link)
(B 'org-referent-get-base)
(error (lambda nil
(error "Invalid property: %S"
prop))))
(when no-cache (log " %S no cache" P))
(org-with-point-at
(or (plist-get kargs :epom)
(and L (always (log " %S locate" P))
(locate L t)))
;; 置 :epom 以便后续递归调用时无需再定位。
(plist-put kargs :epom (point-marker))
(cond
;; prop 是 string, 代表 Org属性 的字符串。
((stringp P)
(!let ((v (org-entry-get nil P)))
(if no-cache v (put-cache L P v))))
;; prop 是 lambda.
((not (symbolp P))
(if (functionp P) (P) (error)))
;; prop 是 symbol.
((ignore (setup-dependencies L P)))
;; prop 无 base.
((null (setq B (get P B)))
(unless (functionp P) (error))
(if no-cache (P) (put-cache L P (P))))
;; prop 有 base.
((!let ((v (apply get-prop L B kargs)))
(cond
(no-cache v)
((or (stringp B) (symbolp B))
(bind-value L P B))
((put-cache L P v))))))))))
;;;; locate
(!def locate
(lambda (link &optional signal-errors)
(let ((inhibit-message t)
(message-log-max nil)
(org-link-search-must-match-exact-headline t)
(org-link-frame-setup
`((file . find-file-other-window)
,@org-link-frame-setup))
(marker (make-marker)))
(condition-case msg
(save-window-excursion
;; 这个 guard 实际只对当前 buffer 有效，
;; 无法处理 open-link 跑到别的 buffer 的
;; 情况。但考虑到有时我们会 open 当前
;; buffer 中的 link, 为了防止因为可见性引
;; 发的链接查找失败，我们还是在这里加上这
;; 个 gaurd, 当然，也许还有更好的实现方法，
;; 但到时再说。
(org-with-wide-buffer
(if (not (stringp link))
(org-link-open link t)
(org-link-open-from-string link t))
(set-marker marker (point))))
(error
(when signal-errors
(signal (car msg) (cdr msg))))))))
;;;; log
(!def log
(lambda (log-target)
(lambda (fmt &rest args)
(when debug-on-error
(let* ((ts (format-time-string
"[%Y-%m-%d %H:%M:%S.%3N]"))
(buf (get-buffer-create
log-target)))
(with-current-buffer buf
(goto-char (point-max)))
(princ
(concat
(mapconcat
(lambda (line) (concat ts line))
(string-split
(apply #'format fmt args) "\n")
"\n")
"\n")
buf))))))
(!def log (log " log:org-referent-get"))
;;;; bind-value
(!def bind-value
;; depends: cache.
(lambda (link prop base)
;; org-persist 会破坏此处的引用式值共
;; 享，在其 index.eld 中，引用消失，仅
;; 剩值。只有属性被强制更新时才会重新建
;; 立共享引用。
(and-let* ((P (gethash link cache))
(V (last (gethash base P)))
(C (cons t (cons nil V)))
(_ (puthash prop C P)))
;; 返回属性缓存值
(car V))))
;;;; compute-value
(!def compute-value
(lambda (prop val)
(!let ((apply 'org-referent-get-apply)
(val val))
(cond
((or (not (symbolp prop))
(null (setq apply (get prop apply))))
val)
((functionp apply) (apply val))
(t (val))))))
;;;; add-dependent
(!def add-dependent
;; depends: get-cache, log.
(lambda (link base prop)
(and-let* ((C (get-cache link base t)))
(unless (memq prop (nth 1 C))
(setf (nth 1 C) `(,@(nth 1 C) ,prop))
(log " %S dependent %S" base (nth 1 C))))))
;;;; setup-dependencies
(!def setup-dependencies
;; depends: add-dependent, log.
(lambda (link prop)
(dolist (dep (get prop 'org-referent-get-depends))
(log " depend on: %s" dep)
(add-dependent link dep prop))))
;;;; invalidate-dependent
(!def invalidate-dependent
;; depends: cache, log.
(lambda (link property)
(and-let* ((P (gethash link cache))
(C (gethash property P))
(depends 'org-referent-get-depends))
;; 移除可能无效的 PROPERTIES.
(setf (nth 1 C)
(seq-remove
(lambda (p)
(or (not (symbolp p))
(not (functionp p))
(not (member property
(get p depends)))))
(nth 1 C)))
(log " %S dependent: %S" property (nth 1 C))
;; 使 PROPERTIES 缓存失效.
(dolist (p (nth 1 C))
(when (gethash p P)
(setf (gethash p P) nil))))))
;;;; end
;; 延迟加载
;; depends: org-referent-get, cache.
(lambda (&rest a)
"No load. load by
M-x org-referent-get or M-: (org-referent-get)."
(interactive)
(!def 'org-referent-get org-referent-get)
(require 'org-persist)
(!def cache
(or (cadr
(org-persist-read
"org-referent--cache"
nil nil nil :read-related t))
(make-hash-table :test #'equal)))
(org-persist-register
`("org-referent--cache" (elisp-data ,cache))
nil :write-immediately t :expiry 'never)
(if (called-interactively-p 'interactive)
(call-interactively #'org-referent-get)
(apply org-referent-get a)))))
;;; org-N -*- lexical-binding: t; -*-
;; (require 'org)
;; (require 'org-element)
(defun org-N (property &optional link &rest kargs)
"除 :type 外，所有参数均与 ‘org-referent-get’ 一致。"
(declare (indent 2))
(let ((at-point? (null link))
(type (or (plist-get kargs :type) "N")))
(setq kargs (org-plist-delete kargs :type))
;; 试寻 PROPERTY 完整定义。
;; (org-N 'P) -> (org-N 'org-TYPE.P)
(and-let*
((_ (and type (symbolp property)))
(fn (format "org-%s.%s" type property))
(fn (intern-soft fn))
(_ (fboundp fn)))
(setq property fn))
;; 如 LINK nil, 于当前位置生成 LINK.
(when at-point?
(setq link (org-store-link nil nil))
(unless link
(user-error
"Not link refer to position %S %S"
(current-buffer) (point)))
;; (message "org-N at point: %s" link)
;; 截掉 LINK 的中括号。
(with-temp-buffer
(save-excursion (insert link))
(setq link (org-element-property
:raw-link
(org-element-link-parser)))))
(apply #'org-referent-get link property kargs)))
(defmacro org-N-defprop (property base &rest kargs)
"定义 Org节点 属性。
此宏会定义一个名为 ‘org-TYPE.PROPERTY’ 的 Emacs 命令。
‘org-TYPE.PROPERTY’ 以 BASE 为基础，获取并返回属性值。
作为命令调用时，更新属性缓存，并拷贝属性值至 kill-ring.
PROPERTY 为 unquoted symbol. BASE 可以是 string,
quoted symbol, 无参 lambda, 用于从节点中提取属性。详见
‘org-referent-get’.
KARGS:
:type, 指定 TYPE, 可选，默认 “N”.
(org-N-defprop id \"ID\") => org-N.id
(org-N-defprop id \"ID\" :type \\='id) => org-id.id
:get, ‘org-TYPE.PROPERTY’的实现，可选。
get 为一个可零参调用的 lambda, 调用后返回 PROPERTY
的属性值。其执行环境中存在一个绑定变量 fn, 其值为
‘org-TYPE.PROPERTY’. 该 lambda可借
(eq this-command fn) 判断是否为交互式调用。
‘org-N-defprop’ 对 get 有一个要求：当交互式调用时，
强制更新属性缓存。用例：
(org-N-defprop ...
:get
(lambda (&optional any variables)
(if (eq this-command fn)
(get-value-update)
(get-value))))
:apply, :depends 同 ‘org-referent-get’."
(declare (indent defun))
(let* ((type (or (plist-get kargs :type) "N"))
;; fn 名称
(fn (format "org-%s.%s" type property))
(fn (intern fn))
;; fn 默认实现
(fn-impl
`(lambda (&optional link use-cache)
"LINK: Org 链接。
USE-CACHE: nil 禁缓存, t 用缓存, \\='update 更新缓存。"
;; variables from env: fn, apply.
(let ((use-cache
(if (eq this-command fn)
'update use-cache))
kargs)
(pcase use-cache
(`nil (setq kargs `(:no-cache t)))
(`update (setq kargs `(:force t))))
(apply #'org-N fn link kargs))))
(fn-impl (or (plist-get kargs :get) fn-impl))
(fn-arglist (help-function-arglist fn-impl))
(fn-args (seq-difference
fn-arglist '(&optional &rest)))
(fn-doc (or (documentation fn-impl) "")))
;; 根据 BASE 及 fn-impl 生成 docstring.
(if (or (stringp base)
(and (cadr base) (symbolp (cadr base))))
;; string 或 quoted symbol.
(setq fn-doc (format
"返回基于 %S 的节点属性。
交互式调用时，强制更新属性缓存，并拷贝属性值至 kill-ring.
%s"
base fn-doc))
;; lambda
(when (functionp base)
(setq fn-doc
(format "%s\n\n%s"
(or (documentation base) "")
fn-doc))))
(setq fn-doc (string-trim fn-doc))
;; 定义属性函数
`(!let* ((fn ',fn) (fn-impl ,fn-impl))
(org-referent-get 'set fn :base ,base)
(org-referent-get 'set fn
:apply ,(plist-get kargs :apply))
(org-referent-get 'set fn
:depends ,(plist-get kargs :depends))
(!def fn
(lambda ,fn-arglist
,fn-doc
(interactive)
(let* ((v (fn-impl ,@fn-args)))
(when (eq this-command fn)
(kill-new (format "%s" v))
(message
"Node's %s copied, value: %.50s."
',property v))
v))))))
(org-N-defprop location
;; 因为 marker 无法被持久化，这里我们做些
;; hacking. 当此 lambda 被调用时，我们
;; 用 point 和 file 捕获当前位置。
(lambda nil
(let ((point (point))
(file (buffer-file-name)))
(lambda nil
(set-marker
(make-marker) point
(find-file-noselect file)))))
:apply t)
(org-N-defprop element-type
(lambda nil
(org-element-type
(org-element-at-point-no-context))))
;;; org-id-property -*- lexical-binding: t; -*-
(defun org-id-property (property &optional id force)
"Org ID Property.
PROPERTY: 同 ‘org-referent-get’.
ID: Org ID.
FORCE: t 强制更新缓存。
返回: 属性值。"
(declare (indent 2))
(let ((at-point? (null id)) epom)
(when at-point?
(setq id (org-entry-get nil "ID" t))
(unless id
(user-error
"No ID refer to position %S %S"
(current-buffer) (point)))
;; (message "org-id at point: %s" id)
;; 因为上边获取 ID 时使用了 inherit 的方式
;; 所以需要定位所指位置。 在此代码路径下,
;; ‘org-referent-get’具有LINK 及 :epom
;; 信息，无需再定位。
(setq epom (org-find-entry-with-id id)))
(org-N property (format "id:%s" id)
:type 'id :force force :epom epom)))
(defmacro org-id-defprop (name base &rest kargs)
(declare (indent defun))
`(org-N-defprop ,name ,base
:type id
:get
(lambda (&optional id force)
"ID: Org ID.
FORCE: t 强制更新缓存。"
(org-id-property ',name id
(or force (eq this-command fn))))
,@kargs))
(org-id-defprop id "ID") ; => #'org-id.id
(org-id-defprop title "ITEM")
(org-id-defprop todo "TODO")
(org-id-defprop closed "CLOSED")
(org-id-defprop timestamp-ia "TIMESTAMP_IA")
(org-id-defprop tags #'org-get-tags)
(org-id-defprop level #'org-current-level)
(org-id-defprop links
(lambda nil
"返回当前节点中所有 ID 链接。"
(org-with-wide-buffer
(org-narrow-to-subtree)
(org-element-map
(org-element-parse-buffer nil t t)
'(link)
(lambda (link)
(let ((type (org-element-property
:type link)))
(when (string= type "id")
(intern
(org-element-property
:path link)))))))))
(org-id-defprop backlinks
(lambda nil
"返回当前节点所有的 ID 后链。"
(when-let*
;; 同 org-id-property 保持一致，使用 inherited.
((id (org-entry-get nil "ID" t))
(_
(always
(unless (hash-table-p org-id-locations)
(org-id-update-id-locations))))
(scope
(when (hash-table-p org-id-locations)
(seq-uniq
(hash-table-values
org-id-locations))))
(bufs
(mapcar
(lambda (file)
(or (find-buffer-visiting file)
(find-file-noselect file)))
scope))
(backlinks
(mapcan
(lambda (buf)
(let ((re (concat
"\\["
"\\[id:" id "\\]"
"\\(\\[.*?\\]\\)?"
"\\]"))
(m (make-marker))
P)
(org-with-point-at (set-marker m 1 buf)
(save-match-data
(while (re-search-forward re nil t)
(and-let*
((p (org-entry-get
nil "ID" t))
(_ (not (string= p id)))
(p (intern p))
(_ (not (member p P))))
(push p P)))))
P))
bufs))
(backlinks
(seq-remove #'null backlinks)))
backlinks)))
;;; org-id-select -*- lexical-binding: t; -*-
;; (require 'seq)
;; (require 'org)
;; (require 'org-id)
;; (require 'org-clock)
(!def 'org-id-select
(!let (org-id-select
make-match-string select-by-match)
;;;; org-id-select
(!def org-id-select
(lambda (&rest kargs)
"Org ID select.
查询匹配中的 Org ID, 返回 ID 集合。
关键字参数：
候选 ID 集
:id-set 候选 ID 集，可选。非 nil 时 ‘org-id-select’
将从该集合中查询; nil 时从 ‘org-id-locations’
获取。
用例：
(org-id-select
:id-set \\='(a b c)
:match \"+TODO=\\\"DONE\\\"\")
(org-id-select
:id-set \\='(\"a\" \"b\" \"c\")
:match \"+TODO=\\\"DONE\\\"\")
Match 字符串
:match Org Match 字符串，详情见 Info node
‘(org)Matching tags and properties’.
用例：
(org-id-select
:match \"+CREATE_TIME>\\\"[2025-08-10]\\\"\")
时间范围查询
:tprop Org 属性，值为 Org 时间戳；
:block 见 Info node ‘(org)The clock table’;
:tstart 见 Info node ‘(org)The clock table’;
:tend 见 Info node ‘(org)The clock table’.
用例：
(org-id-select
:tprop \"CREATE_TIME\" :block \\='2025-08)
排序
:sort-by id 到 key 的映射；
:< key 比较函数。
用例：
(org-id-select
:match \"+ITEM={Task.*}\"
:tprop \"CREATE_TIME\" :block \\='today
:sort-by #\\='org-id->time :< #\\='time-less-p)"
(let* ((match (make-match-string kargs))
(id-set
(or (plist-get kargs :id-set)
(unless (hash-table-p
org-id-locations)
(org-id-update-id-locations)
nil)
(when (hash-table-p
org-id-locations)
(hash-table-keys
org-id-locations))))
(ids (select-by-match id-set match))
(sort-by (plist-get kargs :sort-by))
(< (or (plist-get kargs :<) #'<))
(ids (cond
(sort-by
(seq-sort-by sort-by < ids))
((plist-get kargs :<)
(seq-sort < ids))
(t ids))))
ids)))
;;;; make-match-string
(!def make-match-string
(lambda (kargs)
(let* ((match (plist-get kargs :match))
(block (plist-get kargs :block))
(tstart (plist-get kargs :tstart))
(tend (plist-get kargs :tend))
(tprop0 (plist-get kargs :tprop))
(tprop1 (or (plist-get kargs :tprop1)
tprop0))
(range
(when block
(org-clock-special-range
block nil t)))
(tstart (or tstart (car range)))
(tend (or tend (cadr range)))
(match
(if (null tprop0) match
(concat
match
"+" tprop0 ">=\"" tstart "\""
"+" tprop1 "<\"" tend "\""))))
match)))
;;;; select-by-match
(!def select-by-match
(lambda (id-set mstr)
;; org 会使用 match 字符串构造一个 lambda (具体见
;; `org-make-tags-matcher'), 我们直接重构该 lambda,
;; 使其以 id 为入参，并用 `org-N' 获取属性。
(!let* ((fn
(cl-letf
;; 防止 org-make-tags-matcher 编译
;; lambda.
(((symbol-function #'byte-compile)
#'identity))
(seq-remove
(lambda (s)
(eq (car-safe s) 'ignore))
(cdr (org-make-tags-matcher mstr)))))
(body (flatten-list (car (last fn))))
;; 于此 hack 掉原本的 `org-entry-get'.
(bindings
`((link (format "id:%s" id))
(org-entry-get
(lambda (_ P &rest _)
(org-N P link)))
,(when (memq 'todo body)
'(todo
(org-N "TODO" link)))
,(when (memq 'tags-list body)
'(tags-list
(string-split
(or (org-N "TAGS" link)
"")
":" t)))
,(when (memq 'level body)
'(level
(org-N "LEVEL" link)))))
(bindings (seq-remove #'null bindings)))
;; 改 lambda 参数列表及变量绑定。
(setf (nth 1 fn) '(id))
(setf (car (last fn))
`(!let* (,@bindings) ,(car (last fn))))
(seq-filter (byte-compile fn) id-set))))
;;;; end
org-id-select))
;;; ends here