Skip to content

Commit 9a93d6a

Browse files
jkitchinjkitchin
committed
updates to org-db. This fixes some performance issues I had on the main branch, and adds features like org-db-agenda I think.
1 parent 09c9d13 commit 9a93d6a

File tree

4 files changed

+1041
-683
lines changed

4 files changed

+1041
-683
lines changed

‎org-db-agenda.el

+149-25
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,12 @@
11
;;; org-db-agenda.el --- Agenda from org-db
22

33
;;; Commentary:
4-
;;
4+
;;
5+
6+
(require 'org-archive)
7+
(require 'org-db)
8+
(require 'pcache)
9+
510

611
(defun org-db-agenda--candidates (before-date)
712
"Get headings with deadlines before BEFORE-DATE
@@ -11,27 +16,56 @@ today Due by today
1116
+1m Due in a month
1217
"
1318
(interactive)
14-
(let* ((headings (emacsql org-db [:select [headlines:level headlines:title headlines:tags
15-
files:filename headlines:begin
16-
headlines:deadline
17-
files:last-updated
18-
headlines:todo-keyword]
19-
:from headlines
20-
:inner :join files
21-
:on (= files:rowid headlines:filename-id)
19+
(let* ((deadline-headings (with-org-db
20+
(emacsql org-db [:select [headlines:level headlines:title headlines:tags
21+
files:filename headlines:begin
22+
headlines:deadline
23+
files:last-updated
24+
headlines:todo-keyword]
25+
:from headlines
26+
:inner :join files
27+
:on (= files:rowid headlines:filename-id)
2228
;only get deadlines before now
23-
:where (and
24-
(= headlines:todo-keyword "TODO")
25-
(< headlines:deadline $s1))
26-
:order :by headlines:deadline :desc]
27-
(float-time (org-read-date t t before-date))))
28-
(candidates (cl-loop for (level title tags filename begin deadline last-updated todo-keyword) in headings
29+
:where (and
30+
(= headlines:todo-keyword "TODO")
31+
(is headlines:archivedp (not nil))
32+
(< headlines:deadline $s1))
33+
:order :by headlines:deadline :desc]
34+
(float-time (org-read-date t t before-date)))))
35+
36+
(todo-headings (with-org-db
37+
(emacsql org-db [:select [headlines:level headlines:title headlines:tags
38+
files:filename headlines:begin
39+
headlines:deadline
40+
files:last-updated
41+
headlines:todo-keyword]
42+
:from headlines
43+
:inner :join files
44+
:on (= files:rowid headlines:filename-id)
45+
;; headlines with TODO state but no deadline, and not archived
46+
:where (and
47+
(= headlines:todo-keyword "TODO")
48+
(is headlines:deadline (not nil))
49+
(is headlines:archivedp (not nil)))
50+
:order :by files:last-updated :desc])))
51+
(ignores (pcache-get (pcache-repository :file "org-db-agenda-ignore") 'ignores))
52+
(candidates (cl-loop for (level title tags filename begin deadline last-updated todo-keyword)
53+
in (append deadline-headings todo-headings)
54+
when (not (member filename ignores))
2955
collect
3056
(cons
31-
(format "%20s|%100s|%20s|%s|%s"
32-
(s-pad-right 20 " " (format-time-string "<%Y-%m-%d %a %H:%M:%S>" (seconds-to-time deadline)))
57+
(format "%28s|%100s|%20s|%s|%s"
58+
(s-pad-right 28 " "
59+
(if deadline
60+
(format-time-string
61+
"<%Y-%m-%d %a %H:%M:%S>"
62+
(seconds-to-time deadline))
63+
" "))
3364

34-
(s-pad-right 100 " " (concat (make-string level (string-to-char "*")) " "
65+
(s-pad-right 100 " " (concat (make-string
66+
level
67+
(string-to-char "*"))
68+
" "
3569
todo-keyword " "
3670
title))
3771
(s-pad-right 20 " " (or tags ""))
@@ -43,29 +77,119 @@ today Due by today
4377
:title title)))))
4478
candidates))
4579

80+
4681
(defun org-db-agenda-transformer (candidate)
82+
"Add colors to candidates."
4783
(let* ((now (float-time (current-time)))
4884
(ts (string-match org-element--timestamp-regexp candidate))
49-
(es (when ts (float-time (org-timestamp-to-time (org-timestamp-from-string (match-string 0 candidate)))))))
50-
(if es
51-
(if (> es now)
52-
(propertize candidate 'face '(:foreground "green4"))
53-
(propertize candidate 'face '(:foreground "dark red")))
54-
candidate)))
85+
(es (when ts (float-time (org-timestamp-to-time
86+
(org-timestamp-from-string
87+
(match-string 0 candidate)))))))
88+
(cond
89+
((null es) candidate)
90+
((> es now) (propertize candidate 'face '(:foreground "green4")))
91+
((< es now) (propertize candidate 'face '(:foreground "dark red"))))))
5592

5693

5794
(ivy-configure 'org-db-agenda :display-transformer-fn
5895
#'org-db-agenda-transformer)
5996

6097

98+
(defun org-db-agenda--done (candidate)
99+
"Mark the current candidate as done."
100+
(let ((plist (cdr candidate)))
101+
(find-file (plist-get plist :file))
102+
(goto-char (plist-get plist :begin))
103+
(org-todo "DONE")
104+
(save-buffer)
105+
(org-db-update-buffer t)))
106+
107+
108+
(defun org-db-agenda--archive (candidate)
109+
"Mark the current candidate as done."
110+
(let ((plist (cdr candidate)))
111+
(find-file (plist-get plist :file))
112+
(goto-char (plist-get plist :begin))
113+
(org-archive-set-tag)
114+
(save-buffer)
115+
(org-db-update-buffer t)))
116+
117+
118+
(defun org-db-agenda--archive-subtree (candidate)
119+
"Mark the current candidate as done."
120+
(let ((plist (cdr candidate)))
121+
(find-file (plist-get plist :file))
122+
(goto-char (plist-get plist :begin))
123+
(org-archive-subtree)
124+
(save-buffer)
125+
(org-db-update-buffer t)))
126+
127+
128+
(defun org-db-agenda--ignore (candidate)
129+
"add CANDIDATE to ignore list."
130+
(let* ((plist (cdr candidate))
131+
(repo (pcache-repository :file "org-db-agenda-ignore"))
132+
(ignores (pcache-get repo 'ignores)))
133+
(setq ignores (delete-dups (append ignores (list (plist-get plist :file)))))
134+
(pcache-put repo 'ignores ignores)))
135+
136+
137+
(defun org-db-agenda--update (candidate)
138+
"Update current entry"
139+
(let* ((plist (cdr candidate))
140+
(fname (plist-get plist :file)))
141+
(with-current-buffer (find-file-noselect fname)
142+
(org-db-update-buffer t))))
143+
144+
61145
(defun org-db-agenda (before)
62146
(interactive (list (read-string "Before (e.g. +2w)" "+2w")))
63147
(let* ((candidates (org-db-agenda--candidates before)))
64148
(ivy-read "heading: " candidates
65149
:caller 'org-db-agenda
66150
:action
67151
'(1
68-
("o" org-db-headings--open "Open to heading.")))))
152+
("o" org-db-headings--open "Open to heading.")
153+
("d" org-db-agenda--done "Mark entry done")
154+
("a" org-db-agenda--archive "Add archive tag")
155+
("A" org-db-agenda--archive-subtree "Archive subtree")
156+
("i" org-db-agenda--ignore "Ignore this file")
157+
("u" org-db-agenda--update "Update file in database")
158+
("U" (lambda (_) (org-db-agenda-refresh "+2w")) "Refresh agenda database")))))
159+
160+
161+
(defun scimax-all-headings-done ()
162+
"Mark all entries in buffer as DONE."
163+
(interactive)
164+
(org-map-entries
165+
(lambda ()
166+
(when (org-get-repeat)
167+
(org-todo -1))
168+
(when (string= (org-get-todo-state) "TODO")
169+
(org-todo "DONE")))))
170+
171+
172+
(defun scimax-archive-todo-headings ()
173+
"Make todo entries archived."
174+
(interactive)
175+
(org-map-entries
176+
(lambda ()
177+
(when (string= (org-get-todo-state) "TODO")
178+
(org-archive-set-tag)))))
179+
180+
181+
(defun org-db-agenda-refresh (before)
182+
"Refresh agenda files."
183+
(interactive (list (read-string "Before (e.g. +2w)" "+2w")))
184+
(cl-loop for candidate in (org-db-agenda--candidates before) do
185+
(let* ((fname (plist-get (cdr candidate) :file))
186+
(open (get-file-buffer fname))
187+
(buf (find-file-noselect fname)))
188+
(with-current-buffer buf
189+
(org-db-update-buffer t))
190+
(when (null open)
191+
(kill-buffer buf)))))
192+
69193

70194

71195
(provide 'org-db-agenda)

‎org-db-fulltext.el

+61-12
Original file line numberDiff line numberDiff line change
@@ -3,32 +3,63 @@
33
;;; Commentary:
44
;;
55
;; Add fulltext search for org-db.
6+
;;
7+
;; TODO replace org-db-ft
8+
9+
(require 'org-db)
610

711
(defcustom org-db-fulltext "org-db-fulltext.sqlite"
812
"Name of the sqlite database file for full-text search."
913
:type 'string
1014
:group 'org-db)
1115

1216

13-
(defvar org-db-ft (emacsql-sqlite (expand-file-name org-db-fulltext org-db-root))
17+
(defvar org-db-ft nil
1418
"Variable for the ‘org-db’ full-text connection.")
1519

20+
21+
(defmacro with-org-db-ft (&rest body)
22+
"Run BODY commands in an org-db context where we open the database, and close it at the end.
23+
BODY should be regular commands. They can use the variable `org-db' in them."
24+
`(progn
25+
(unless (and org-db-ft (emacsql-live-p org-db-ft))
26+
(setq org-db-ft (emacsql-sqlite (expand-file-name org-db-fulltext org-db-root) :debug t)))
27+
(prog1
28+
(progn
29+
,@body)
30+
(emacsql-close org-db-ft)
31+
(emacsql-close org-db-ft)
32+
(setq org-db-ft nil)))
33+
34+
;; `(let* ((org-db-ft (emacsql-sqlite (expand-file-name org-db-fulltext org-db-root)))
35+
;; (results))
36+
;; (prog1
37+
;; (condition-case err
38+
;; ,@body
39+
;; (org-db-log "Error fulltext: %s" err))
40+
;; ;; It seems like you need to call this twice before org-db is nil
41+
;; (emacsql-close org-db-ft)
42+
;; (emacsql-close org-db-ft)))
43+
)
44+
1645
;; Make sure the database and table exists
17-
(emacsql org-db-ft [:create-virtual-table :if :not :exists fulltext
18-
:using :fts5
19-
([filename contents])])
46+
(with-org-db-ft
47+
(emacsql org-db-ft [:create-virtual-table :if :not :exists fulltext
48+
:using :fts5
49+
([filename contents])]))
2050

2151

2252

2353
(defun org-db-fulltext-update (_filename-id _parse-tree)
2454
"Insert the full text for searching."
25-
(emacsql org-db-ft [:delete :from fulltext :where (= filename $s1)] (buffer-file-name))
55+
(with-org-db-ft
56+
(emacsql org-db-ft [:delete :from fulltext :where (= filename $s1)] (buffer-file-name))
2657

27-
(emacsql org-db-ft [:insert :into fulltext :values [$s1 $s2]]
28-
(buffer-file-name)
29-
(save-restriction
30-
(widen)
31-
(buffer-substring-no-properties (point-min) (point-max)))))
58+
(emacsql org-db-ft [:insert :into fulltext :values [$s1 $s2]]
59+
(buffer-file-name)
60+
(save-restriction
61+
(widen)
62+
(buffer-substring-no-properties (point-min) (point-max))))))
3263

3364

3465
(add-to-list 'org-db-update-functions #'org-db-fulltext-update t)
@@ -41,8 +72,26 @@ to change this. It could be nice to find some way to read in an
4172
emacsql query like :match '\"something.\" Alternatively, I may
4273
need a better async version."
4374
(interactive)
44-
(let ((candidates (emacsql org-db-ft [:select [contents filename] :from fulltext])))
45-
(ivy-read "query: " candidates)))
75+
(let ((candidates (with-org-db-ft
76+
(emacsql org-db-ft [:select [contents filename] :from fulltext]))))
77+
(ivy-read "query: " candidates
78+
:action (lambda (x)
79+
(find-file (cadr x))
80+
(re-search-forward ivy-text)
81+
(goto-char (match-beginning 0))))))
82+
83+
84+
(defun org-db-ft-transformer (s)
85+
"This only shows lines that match the selected pattern."
86+
(s-join "\n"
87+
(cl-loop for x in (split-string s "\n")
88+
if (string-match-p ivy-text x)
89+
collect x)))
90+
91+
92+
(ivy-set-display-transformer
93+
'org-db-fulltext-search
94+
'org-db-ft-transformer)
4695

4796

4897
(provide 'org-db-fulltext)

0 commit comments

Comments
 (0)