Add caching mecanism
* contrib/lisp/org-contacts.el: Add a caching mecanism around `org-contacts-filter'.
This commit is contained in:
parent
fb87d0eac0
commit
d630e91dee
1 changed files with 51 additions and 25 deletions
|
@ -139,38 +139,64 @@ This overrides `org-email-link-description-format' if set."
|
||||||
map)
|
map)
|
||||||
"The keymap used in `org-contacts' result list.")
|
"The keymap used in `org-contacts' result list.")
|
||||||
|
|
||||||
|
(defvar org-contacts-db nil
|
||||||
|
"Org Contacts database.")
|
||||||
|
|
||||||
|
(defvar org-contacts-last-update nil
|
||||||
|
"Last time the Org Contacts database has been updated.")
|
||||||
|
|
||||||
(defun org-contacts-files ()
|
(defun org-contacts-files ()
|
||||||
"Return list of Org files to use for contact management."
|
"Return list of Org files to use for contact management."
|
||||||
(or org-contacts-files (org-agenda-files t 'ifmode)))
|
(or org-contacts-files (org-agenda-files t 'ifmode)))
|
||||||
|
|
||||||
|
(defun org-contacts-db ()
|
||||||
|
"Return the latest Org Contacts Database"
|
||||||
|
(let* (todo-only
|
||||||
|
(contacts-matcher
|
||||||
|
(cdr (org-make-tags-matcher org-contacts-matcher)))
|
||||||
|
(need-update?
|
||||||
|
(or (null org-contacts-last-update)
|
||||||
|
(some (lambda (file)
|
||||||
|
(time-less-p org-contacts-last-update
|
||||||
|
(elt (file-attributes file) 5)))
|
||||||
|
(org-contacts-files))))
|
||||||
|
markers result)
|
||||||
|
(when need-update?
|
||||||
|
(message "Update Org Contacts Database")
|
||||||
|
(dolist (file (org-contacts-files))
|
||||||
|
(org-check-agenda-file file)
|
||||||
|
(with-current-buffer (org-get-agenda-file-buffer file)
|
||||||
|
(unless (eq major-mode 'org-mode)
|
||||||
|
(error "File %s is no in `org-mode'" file))
|
||||||
|
(org-scan-tags
|
||||||
|
'(add-to-list 'markers (set-marker (make-marker) (point)))
|
||||||
|
contacts-matcher
|
||||||
|
todo-only)))
|
||||||
|
(dolist (marker markers result)
|
||||||
|
(org-with-point-at marker
|
||||||
|
(add-to-list 'result
|
||||||
|
(list (org-get-heading t) marker (org-entry-properties marker 'all)))))
|
||||||
|
(setf org-contacts-db result
|
||||||
|
org-contacts-last-update (current-time)))
|
||||||
|
org-contacts-db))
|
||||||
|
|
||||||
(defun org-contacts-filter (&optional name-match tags-match)
|
(defun org-contacts-filter (&optional name-match tags-match)
|
||||||
"Search for a contact maching NAME-MATCH and TAGS-MATCH.
|
"Search for a contact maching NAME-MATCH and TAGS-MATCH.
|
||||||
If both match values are nil, return all contacts."
|
If both match values are nil, return all contacts."
|
||||||
(let* (todo-only
|
(if (and (null name-match)
|
||||||
(tags-matcher
|
(null tags-match))
|
||||||
(if tags-match
|
(org-contacts-db)
|
||||||
(cdr (org-make-tags-matcher tags-match))
|
(loop for contact in (org-contacts-db)
|
||||||
t))
|
if (or
|
||||||
(name-matcher
|
(and name-match
|
||||||
(if name-match
|
(org-string-match-p name-match
|
||||||
'(org-string-match-p name-match (org-get-heading t))
|
(first contact)))
|
||||||
t))
|
(and tags-match
|
||||||
(contacts-matcher
|
(some (lambda (tag)
|
||||||
(cdr (org-make-tags-matcher org-contacts-matcher)))
|
(org-string-match-p tags-match tag))
|
||||||
markers result)
|
(org-split-string
|
||||||
(dolist (file (org-contacts-files))
|
(or (cdr (assoc-string "ALLTAGS" (caddr contact))) "") ":"))))
|
||||||
(org-check-agenda-file file)
|
collect contact)))
|
||||||
(with-current-buffer (org-get-agenda-file-buffer file)
|
|
||||||
(unless (eq major-mode 'org-mode)
|
|
||||||
(error "File %s is no in `org-mode'" file))
|
|
||||||
(org-scan-tags
|
|
||||||
'(add-to-list 'markers (set-marker (make-marker) (point)))
|
|
||||||
`(and ,contacts-matcher ,tags-matcher ,name-matcher)
|
|
||||||
todo-only)))
|
|
||||||
(dolist (marker markers result)
|
|
||||||
(org-with-point-at marker
|
|
||||||
(add-to-list 'result
|
|
||||||
(list (org-get-heading t) marker (org-entry-properties marker 'all)))))))
|
|
||||||
|
|
||||||
(when (not (fboundp 'completion-table-case-fold))
|
(when (not (fboundp 'completion-table-case-fold))
|
||||||
;; That function is new in Emacs 24...
|
;; That function is new in Emacs 24...
|
||||||
|
|
Loading…
Reference in a new issue