Rewrite of contrib/lisp/org-velocity.el.
From the author: "This is a rewrite of Org-Velocity for speed. Delays due to file size should no longer be perceptible. I have also added in-line previews of entry contents and dropped support for Org-Remember."
This commit is contained in:
Paul M. Rodriguez
Bastien Guerry
parent
b7f5efdc4e
commit
bf25b68915
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
|
||||
;; Created: 2010-05-05
|
||||
;; Version: 2.4
|
||||
;; Version: 3.0
|
||||
|
||||
;; This file is not part of GNU Emacs.
|
||||
|
||||
|
|
@ -58,7 +58,7 @@
|
|||
;;; Usage:
|
||||
;; (require 'org-velocity)
|
||||
;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory))
|
||||
;; (global-set-key (kbd "C-c v") 'org-velocity-read)
|
||||
;; (global-set-key (kbd "C-c v") 'org-velocity)
|
||||
|
||||
;;; Code:
|
||||
(require 'org)
|
||||
|
|
@ -85,6 +85,12 @@
|
|||
:type 'boolean
|
||||
:safe 'booleanp)
|
||||
|
||||
(defcustom org-velocity-show-previews t
|
||||
"Show previews of the text of each heading?"
|
||||
:group 'velocity
|
||||
:type 'boolean
|
||||
:safe 'booleanp)
|
||||
|
||||
(defcustom org-velocity-exit-on-match nil
|
||||
"When searching incrementally, exit on a single match?"
|
||||
:group 'org-velocity
|
||||
|
|
@ -97,14 +103,6 @@
|
|||
:type 'boolean
|
||||
:safe 'booleanp)
|
||||
|
||||
(defcustom org-velocity-max-depth nil
|
||||
"Ignore headings deeper than this."
|
||||
:group 'org-velocity
|
||||
:type '(choice
|
||||
(const :tag "No maximum depth" nil)
|
||||
(integer :tag "Set maximum depth"))
|
||||
:safe (lambda (v) (or (null v) (wholenump v))))
|
||||
|
||||
(defcustom org-velocity-use-search-ring t
|
||||
"Push search to `search-ring' when visiting an entry?
|
||||
|
||||
|
|
@ -132,12 +130,6 @@ file."
|
|||
(const :tag "Use completion" t))
|
||||
:safe 'booleanp)
|
||||
|
||||
(defcustom org-velocity-edit-indirectly t
|
||||
"Edit entries in an indirect buffer or just visit the file?"
|
||||
:group 'org-velocity
|
||||
:type 'boolean
|
||||
:safe 'booleanp)
|
||||
|
||||
(defcustom org-velocity-search-method 'phrase
|
||||
"Match on whole phrase, any word, or all words?"
|
||||
:group 'org-velocity
|
||||
|
|
@ -148,28 +140,6 @@ file."
|
|||
(const :tag "Match a regular expression" regexp))
|
||||
:safe (lambda (v) (memq v '(phrase any all regexp))))
|
||||
|
||||
(defcustom org-velocity-create-method 'capture
|
||||
"Prefer `org-capture', `org-remember', or neither?"
|
||||
:group 'org-velocity
|
||||
:type '(choice
|
||||
(const :tag "Prefer capture > remember > default." capture)
|
||||
(const :tag "Prefer remember > default." remember)
|
||||
(const :tag "Edit in buffer." buffer))
|
||||
:safe (lambda (v) (memq v '(capture remember buffer))))
|
||||
|
||||
(defcustom org-velocity-remember-templates
|
||||
'(("Velocity entry"
|
||||
?v
|
||||
"* %:search\n\n%i%?"
|
||||
nil
|
||||
bottom))
|
||||
"Use these templates with `org-remember'.
|
||||
Meanwhile `org-default-notes-file' is bound to `org-velocity-use-file'.
|
||||
The keyword :search inserts the current search.
|
||||
See the documentation for `org-remember-templates'."
|
||||
:group 'org-velocity
|
||||
:type (or (get 'org-remember-templates 'custom-type) 'list))
|
||||
|
||||
(defcustom org-velocity-capture-templates
|
||||
'(("v"
|
||||
"Velocity entry"
|
||||
|
|
@ -177,19 +147,48 @@ See the documentation for `org-remember-templates'."
|
|||
(file "")
|
||||
"* %:search\n\n%i%?"))
|
||||
"Use these template with `org-capture'.
|
||||
Meanwhile `org-default-notes-file' is bound to `org-velocity-use-file'.
|
||||
Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'.
|
||||
The keyword :search inserts the current search.
|
||||
See the documentation for `org-capture-templates'."
|
||||
:group 'org-velocity
|
||||
:type (or (get 'org-capture-templates 'custom-type) 'list))
|
||||
|
||||
(defstruct (org-velocity-heading
|
||||
(:constructor org-velocity-make-heading
|
||||
(&aux (components (org-heading-components))))
|
||||
(:type list))
|
||||
(marker (point-marker))
|
||||
(name (nth 4 components))
|
||||
(level (nth 0 components)))
|
||||
(defsubst org-velocity-grab-preview ()
|
||||
"Grab preview of a subtree.
|
||||
The length of the preview is determined by `window-width'.
|
||||
|
||||
Replace all contiguous whitespace with single spaces."
|
||||
(let ((start (progn
|
||||
(forward-line 1)
|
||||
(if (looking-at org-property-start-re)
|
||||
(re-search-forward org-property-end-re)
|
||||
(1- (point))))))
|
||||
(mapconcat
|
||||
#'identity
|
||||
(split-string
|
||||
(buffer-substring-no-properties
|
||||
start
|
||||
(min
|
||||
(+ start (window-width))
|
||||
(point-max))))
|
||||
" ")))
|
||||
|
||||
(defstruct org-velocity-heading buffer position name level preview)
|
||||
|
||||
(defsubst org-velocity-nearest-heading (position)
|
||||
"Return last heading at POSITION.
|
||||
If there is no last heading, return nil."
|
||||
(save-excursion
|
||||
(goto-char position)
|
||||
(re-search-backward org-velocity-heading-regexp)
|
||||
(let ((components (org-heading-components)))
|
||||
(make-org-velocity-heading
|
||||
:buffer (current-buffer)
|
||||
:position (point)
|
||||
:name (nth 4 components)
|
||||
:level (nth 0 components)
|
||||
:preview (if org-velocity-show-previews
|
||||
(org-velocity-grab-preview))))))
|
||||
|
||||
(defconst org-velocity-index
|
||||
(eval-when-compile
|
||||
|
|
@ -198,15 +197,18 @@ See the documentation for `org-capture-templates'."
|
|||
(number-sequence 65 90))) ;uppercase letters
|
||||
"List of chars for indexing results.")
|
||||
|
||||
(defconst org-velocity-display-buffer-name "*Velocity headings*")
|
||||
(defconst org-velocity-match-buffer-name "*Velocity matches*")
|
||||
|
||||
(defconst org-velocity-heading-regexp "^\\* "
|
||||
"Regexp to match only top-level headings.")
|
||||
|
||||
(defvar org-velocity-search nil
|
||||
"Variable to bind to current search.")
|
||||
|
||||
(defsubst org-velocity-buffer-file-name (&optional buffer)
|
||||
(defun org-velocity-buffer-file-name (&optional buffer)
|
||||
"Return the name of the file BUFFER saves to.
|
||||
Same as function `buffer-file-name' unless BUFFER is an indirect
|
||||
buffer or a minibuffer. In the former case, return the file name
|
||||
buffer or a minibuffer. In the former case, return the file name
|
||||
of the base buffer; in the latter, return the file name of
|
||||
`minibuffer-selected-window' (or its base buffer)."
|
||||
(let ((buffer (if (minibufferp buffer)
|
||||
|
|
@ -222,71 +224,55 @@ of the base buffer; in the latter, return the file name of
|
|||
(with-current-buffer (window-buffer (active-minibuffer-window))
|
||||
(minibuffer-contents))))
|
||||
|
||||
(defun org-velocity-use-file ()
|
||||
"Return the proper file for Org-Velocity to search.
|
||||
If `org-velocity-always-use-bucket' is t, use bucket file; complain
|
||||
if missing. Otherwise if this is an Org file, use it."
|
||||
(or
|
||||
;; Use the target in in remember buffers.
|
||||
(if (and (boundp 'org-remember-mode) org-remember-mode)
|
||||
org-default-notes-file)
|
||||
(let ((org-velocity-bucket
|
||||
(and org-velocity-bucket (expand-file-name org-velocity-bucket)))
|
||||
(buffer (if (org-velocity-buffer-file-name)
|
||||
;; Use the target in capture buffers.
|
||||
(org-find-base-buffer-visiting (org-velocity-buffer-file-name)))))
|
||||
(if org-velocity-always-use-bucket
|
||||
(or org-velocity-bucket (error "Bucket required but not defined"))
|
||||
(if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer)))
|
||||
'org-mode)
|
||||
(org-velocity-buffer-file-name))
|
||||
(org-velocity-buffer-file-name)
|
||||
(or org-velocity-bucket
|
||||
(error "No bucket and not an Org file")))))))
|
||||
(defsubst org-velocity-singlep (object)
|
||||
"Return t when OBJECT is a list or sequence of one element."
|
||||
(if (consp object)
|
||||
(null (cdr object))
|
||||
(= (length object) 1)))
|
||||
|
||||
(defsubst org-velocity-display-buffer ()
|
||||
"Return the proper buffer for Org-Velocity to display in."
|
||||
(get-buffer-create org-velocity-display-buffer-name))
|
||||
(defun org-velocity-bucket-file ()
|
||||
"Return the proper file for Org-Velocity to search.
|
||||
If `org-velocity-always-use-bucket' is t, use bucket file;
|
||||
complain if missing. Otherwise, if an Org file is current, then
|
||||
use it."
|
||||
(let ((org-velocity-bucket
|
||||
(when org-velocity-bucket (expand-file-name org-velocity-bucket)))
|
||||
(buffer
|
||||
(let ((buffer-file (org-velocity-buffer-file-name)))
|
||||
(when buffer-file
|
||||
;; Use the target in capture buffers.
|
||||
(org-find-base-buffer-visiting buffer-file)))))
|
||||
(if org-velocity-always-use-bucket
|
||||
(or org-velocity-bucket (error "Bucket required but not defined"))
|
||||
(if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer)))
|
||||
'org-mode)
|
||||
(org-velocity-buffer-file-name))
|
||||
(org-velocity-buffer-file-name)
|
||||
(or org-velocity-bucket
|
||||
(error "No bucket and not an Org file"))))))
|
||||
|
||||
(defvar org-velocity-bucket-buffer nil)
|
||||
|
||||
(defsubst org-velocity-bucket-buffer ()
|
||||
"Return proper buffer for bucket operations."
|
||||
(find-file-noselect (org-velocity-use-file)))
|
||||
(or org-velocity-bucket-buffer
|
||||
(find-file-noselect (org-velocity-bucket-file))))
|
||||
|
||||
(defun org-velocity-nearest-heading (position)
|
||||
"Return last heading at POSITION.
|
||||
If there is no last heading, return nil."
|
||||
(save-excursion
|
||||
(goto-char position)
|
||||
;; If we are before the first heading we could still be at the
|
||||
;; first heading.
|
||||
(unless (and (org-before-first-heading-p)
|
||||
(not (org-at-heading-p)))
|
||||
(org-back-to-heading t)
|
||||
(let ((heading (org-velocity-make-heading)))
|
||||
(if org-velocity-max-depth
|
||||
(if (<= (org-velocity-heading-level heading)
|
||||
org-velocity-max-depth)
|
||||
heading)
|
||||
heading)))))
|
||||
(defsubst org-velocity-match-buffer ()
|
||||
"Return the proper buffer for Org-Velocity to display in."
|
||||
(get-buffer-create org-velocity-match-buffer-name))
|
||||
|
||||
(defun org-velocity-make-button-action (heading)
|
||||
"Return a form to visit HEADING."
|
||||
`(lambda (button)
|
||||
(run-hooks 'mouse-leave-buffer-hook) ;turn off temporary modes
|
||||
(if org-velocity-use-search-ring
|
||||
(add-to-history 'search-ring ,org-velocity-search search-ring-max))
|
||||
(if org-velocity-edit-indirectly
|
||||
(org-velocity-edit-entry ',heading)
|
||||
(progn
|
||||
(message "%s" ,(org-velocity-heading-name heading))
|
||||
(org-pop-to-buffer-same-window (marker-buffer
|
||||
,(org-velocity-heading-marker heading)))
|
||||
(goto-char (marker-position
|
||||
,(org-velocity-heading-marker heading)))))))
|
||||
(defun org-velocity-beginning-of-headings ()
|
||||
"Goto the start of the first heading."
|
||||
(goto-char (point-min))
|
||||
;; If we are before the first heading we could still be at the
|
||||
;; first heading.
|
||||
(or (looking-at org-velocity-heading-regexp)
|
||||
(re-search-forward org-velocity-heading-regexp)))
|
||||
|
||||
(defun org-velocity-make-indirect-buffer (heading)
|
||||
"Make or switch to an indirect buffer visiting HEADING."
|
||||
(let* ((bucket (marker-buffer (org-velocity-heading-marker heading)))
|
||||
|
||||
(let* ((bucket (org-velocity-heading-buffer heading))
|
||||
(name (org-velocity-heading-name heading))
|
||||
(existing (get-buffer name)))
|
||||
(if (and existing (buffer-base-buffer existing)
|
||||
|
|
@ -296,144 +282,168 @@ If there is no last heading, return nil."
|
|||
bucket
|
||||
(generate-new-buffer-name (org-velocity-heading-name heading))))))
|
||||
|
||||
(defun org-velocity-capture ()
|
||||
"Record a note with `org-capture'."
|
||||
(let ((org-capture-templates
|
||||
org-velocity-capture-templates))
|
||||
(org-capture nil
|
||||
;; This is no longer automatically selected.
|
||||
(when (org-velocity-singlep org-capture-templates)
|
||||
(caar org-capture-templates)))
|
||||
(if org-capture-mode (rename-buffer org-velocity-search t))))
|
||||
|
||||
(defvar org-velocity-saved-winconf nil)
|
||||
(make-variable-buffer-local 'org-velocity-saved-winconf)
|
||||
|
||||
(defun org-velocity-edit-entry (heading)
|
||||
"Edit entry at HEADING in an indirect buffer."
|
||||
(let ((buffer (org-velocity-make-indirect-buffer heading)))
|
||||
(with-current-buffer buffer
|
||||
(let ((org-inhibit-startup t))
|
||||
(org-mode))
|
||||
(goto-char (marker-position (org-velocity-heading-marker heading)))
|
||||
(narrow-to-region (point)
|
||||
(save-excursion
|
||||
(org-end-of-subtree t)
|
||||
(point)))
|
||||
(goto-char (point-min))
|
||||
(add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
|
||||
(pop-to-buffer buffer)
|
||||
(set (make-local-variable 'header-line-format)
|
||||
(format "%s Use C-c C-c to finish."
|
||||
(abbreviate-file-name
|
||||
(buffer-file-name
|
||||
(marker-buffer
|
||||
(org-velocity-heading-marker heading))))))))
|
||||
(let ((winconf (current-window-configuration)))
|
||||
(let ((buffer (org-velocity-make-indirect-buffer heading)))
|
||||
(with-current-buffer buffer
|
||||
(let ((org-inhibit-startup t))
|
||||
(org-mode))
|
||||
(setq org-velocity-saved-winconf winconf)
|
||||
(goto-char (org-velocity-heading-position heading))
|
||||
(narrow-to-region (point)
|
||||
(save-excursion
|
||||
(org-end-of-subtree t)
|
||||
(point)))
|
||||
(goto-char (point-min))
|
||||
(add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
|
||||
(pop-to-buffer buffer)
|
||||
(set (make-local-variable 'header-line-format)
|
||||
(format "%s Use C-c C-c to finish."
|
||||
(abbreviate-file-name
|
||||
(buffer-file-name
|
||||
(org-velocity-heading-buffer heading))))))))
|
||||
|
||||
(defun org-velocity-dismiss ()
|
||||
"Save current entry and close indirect buffer."
|
||||
(progn
|
||||
(save-buffer)
|
||||
(kill-buffer)))
|
||||
(let ((winconf org-velocity-saved-winconf))
|
||||
(prog1 t ;Tell hook we're done.
|
||||
(save-buffer)
|
||||
(kill-buffer)
|
||||
(when (window-configuration-p winconf)
|
||||
(set-window-configuration winconf)))))
|
||||
|
||||
(defun org-velocity-buttonize-no-hints (heading)
|
||||
(defun org-velocity-visit-button (button)
|
||||
(run-hooks 'mouse-leave-buffer-hook)
|
||||
(if org-velocity-use-search-ring
|
||||
(add-to-history 'search-ring
|
||||
(button-get button 'search)
|
||||
search-ring-max))
|
||||
(org-velocity-edit-entry (button-get button 'match)))
|
||||
|
||||
(define-button-type 'org-velocity-button
|
||||
'action #'org-velocity-visit-button)
|
||||
|
||||
(defsubst org-velocity-buttonize (heading)
|
||||
"Insert HEADING as a text button with no hints."
|
||||
(let ((action (org-velocity-make-button-action heading)))
|
||||
(insert-text-button
|
||||
(org-velocity-heading-name heading)
|
||||
'action action))
|
||||
(newline))
|
||||
(insert-text-button
|
||||
(propertize (org-velocity-heading-name heading) 'face 'link)
|
||||
:type 'org-velocity-button
|
||||
'match heading
|
||||
'search org-velocity-search))
|
||||
|
||||
(defun org-velocity-buttonize (heading)
|
||||
"Insert HEADING as a text button with an hint."
|
||||
(insert (format "#%c " (nth (1- (line-number-at-pos))
|
||||
org-velocity-index)))
|
||||
(org-velocity-buttonize-no-hints heading))
|
||||
(defsubst org-velocity-insert-preview (heading)
|
||||
(when org-velocity-show-previews
|
||||
(insert-char ?\ 1)
|
||||
(insert
|
||||
(propertize
|
||||
(org-velocity-heading-preview heading)
|
||||
'face 'shadow))))
|
||||
|
||||
(defun org-velocity-remember ()
|
||||
"Use `org-remember' to record a note."
|
||||
(let ((org-remember-templates
|
||||
org-velocity-remember-templates))
|
||||
(call-interactively 'org-remember)
|
||||
(when org-remember-mode
|
||||
(set (make-local-variable 'remember-buffer)
|
||||
(rename-buffer org-velocity-search t)))))
|
||||
(defsubst* org-velocity-present-match (&key hint match)
|
||||
(with-current-buffer (org-velocity-match-buffer)
|
||||
(when hint (insert "#" hint " "))
|
||||
(org-velocity-buttonize match)
|
||||
(org-velocity-insert-preview match)
|
||||
(newline)))
|
||||
|
||||
(defun org-velocity-capture ()
|
||||
"Use `org-capture' to record a note."
|
||||
(let ((org-capture-templates
|
||||
org-velocity-capture-templates))
|
||||
(when (fboundp 'org-capture) ;; quiet compiler
|
||||
(call-interactively 'org-capture)
|
||||
(if org-capture-mode (rename-buffer org-velocity-search t)))))
|
||||
(defun org-velocity-generic-search (search &optional hide-hints)
|
||||
"Display any entry containing SEARCH."
|
||||
(let ((hints org-velocity-index) matches)
|
||||
(block nil
|
||||
(while (and hints (re-search-forward search nil t))
|
||||
(let ((match (org-velocity-nearest-heading (point))))
|
||||
(org-velocity-present-match
|
||||
:hint (unless hide-hints (car hints))
|
||||
:match match)
|
||||
(push match matches))
|
||||
(setq hints (cdr hints))
|
||||
(unless (re-search-forward org-velocity-heading-regexp nil t)
|
||||
(return))))
|
||||
(nreverse matches)))
|
||||
|
||||
(defun org-velocity-insert-heading (&optional heading)
|
||||
"Add a new heading named HEADING and go to it."
|
||||
(let ((heading (or heading org-velocity-search)))
|
||||
(pop-to-buffer (org-velocity-bucket-buffer))
|
||||
(goto-char (point-max))
|
||||
(let ((inhibit-quit t))
|
||||
(newline)
|
||||
(org-insert-heading t t) (insert heading)
|
||||
(newline)
|
||||
(goto-char (point-max)))))
|
||||
(defun* org-velocity-all-search (search &optional hide-hints max)
|
||||
"Display only entries containing every word in SEARCH."
|
||||
(let ((keywords (mapcar 'regexp-quote (split-string search)))
|
||||
(hints org-velocity-index)
|
||||
matches)
|
||||
(org-map-entries
|
||||
(lambda ()
|
||||
;; Return if we've run out of hints.
|
||||
(when (null hints)
|
||||
(return-from org-velocity-all-search (nreverse matches)))
|
||||
;; Only search the subtree once.
|
||||
(setq org-map-continue-from
|
||||
(save-excursion
|
||||
(goto-char (line-end-position))
|
||||
(if (re-search-forward org-velocity-heading-regexp nil t)
|
||||
(line-end-position)
|
||||
(point-max))))
|
||||
(when (loop for word in keywords
|
||||
always (save-excursion
|
||||
(re-search-forward
|
||||
(concat "\\<" word "\\>")
|
||||
org-map-continue-from t)))
|
||||
(let ((match (org-velocity-nearest-heading (match-end 0))))
|
||||
(org-velocity-present-match
|
||||
:hint (unless hide-hints (car hints))
|
||||
:match match)
|
||||
(push match matches)
|
||||
(setq hints (cdr hints))))))
|
||||
(nreverse matches)))
|
||||
|
||||
(defun org-velocity-generic-search (search)
|
||||
"Return entries containing SEARCH."
|
||||
(save-excursion
|
||||
(loop initially (goto-char (point-min))
|
||||
while (re-search-forward search (point-max) t)
|
||||
if (org-velocity-nearest-heading (match-beginning 0))
|
||||
collect it
|
||||
do (outline-next-heading))))
|
||||
(defun* org-velocity-present (search &key hide-hints)
|
||||
"Buttonize matches for SEARCH in `org-velocity-match-buffer'.
|
||||
If HIDE-HINTS is non-nil, display entries without indices. SEARCH
|
||||
binds `org-velocity-search'.
|
||||
|
||||
(defsubst org-velocity-phrase-search (search)
|
||||
"Return entries containing SEARCH as a phrase."
|
||||
(org-velocity-generic-search (regexp-quote search)))
|
||||
|
||||
(defsubst org-velocity-any-search (search)
|
||||
"Return entries containing any word in SEARCH."
|
||||
(org-velocity-generic-search (regexp-opt (split-string search))))
|
||||
|
||||
(defsubst org-velocity-regexp-search (search)
|
||||
(condition-case lossage
|
||||
(org-velocity-generic-search search)
|
||||
(invalid-regexp (minibuffer-message "%s" lossage))))
|
||||
|
||||
(defun org-velocity-all-search (search)
|
||||
"Return entries containing all words in SEARCH."
|
||||
(save-excursion
|
||||
(let ((keywords (mapcar 'regexp-quote (split-string search))))
|
||||
(delq nil
|
||||
(org-map-entries
|
||||
(lambda ()
|
||||
;; Only search the subtree once.
|
||||
(setq org-map-continue-from
|
||||
(save-excursion (org-end-of-subtree t) (point)))
|
||||
(if (loop for word in keywords
|
||||
always (save-excursion
|
||||
(re-search-forward
|
||||
word org-map-continue-from t)))
|
||||
(org-velocity-nearest-heading (point)))))))))
|
||||
|
||||
(defun org-velocity-present (headings &optional no-hints search)
|
||||
"Buttonize HEADINGS in `org-velocity-display-buffer'.
|
||||
If NO-HINTS is non-nil, display entries without indices.
|
||||
SEARCH binds `org-velocity-search'."
|
||||
(and (listp headings) (delete-dups headings))
|
||||
(let ((cdr (nthcdr
|
||||
(1- (length org-velocity-index))
|
||||
headings)))
|
||||
(and (consp cdr) (setcdr cdr nil)))
|
||||
(let ((org-velocity-search search))
|
||||
(with-current-buffer (org-velocity-display-buffer)
|
||||
(mapc
|
||||
(if no-hints 'org-velocity-buttonize-no-hints
|
||||
'org-velocity-buttonize)
|
||||
headings)
|
||||
(goto-char (point-min)))))
|
||||
|
||||
(defun org-velocity-create-1 ()
|
||||
"Create a new heading.
|
||||
The possible methods are `org-velocity-capture',
|
||||
`org-velocity-remember', or `org-velocity-create', in
|
||||
that order. Which is preferred is determined by
|
||||
`org-velocity-create-method'."
|
||||
(funcall
|
||||
(ecase org-velocity-create-method
|
||||
(capture (or (and (featurep 'org-capture) 'org-velocity-capture)
|
||||
(and (featurep 'org-remember) 'org-velocity-remember)
|
||||
'org-velocity-insert-heading))
|
||||
(remember (or (and (featurep 'org-remember) 'org-velocity-remember)
|
||||
'org-velocity-insert-heading))
|
||||
(buffer 'org-velocity-insert-heading))))
|
||||
Return matches."
|
||||
(if (and (stringp search) (not (string= "" search)))
|
||||
;; Fold case when the search string is all lowercase.
|
||||
(let ((case-fold-search (equal search (downcase search)))
|
||||
(truncate-partial-width-windows t))
|
||||
(with-current-buffer (org-velocity-match-buffer)
|
||||
(erase-buffer)
|
||||
;; Permanent locals.
|
||||
(setq cursor-type nil
|
||||
truncate-lines t))
|
||||
(prog1
|
||||
(with-current-buffer (org-velocity-bucket-buffer)
|
||||
(let ((inhibit-point-motion-hooks t)
|
||||
(inhibit-field-text-motion t))
|
||||
(save-excursion
|
||||
(org-velocity-beginning-of-headings)
|
||||
(case org-velocity-search-method
|
||||
(all (org-velocity-all-search search hide-hints))
|
||||
(phrase (org-velocity-generic-search
|
||||
(concat "\\<" (regexp-quote search))
|
||||
hide-hints))
|
||||
(any (org-velocity-generic-search
|
||||
(concat "\\<"
|
||||
(regexp-opt (split-string search)))
|
||||
hide-hints))
|
||||
(regexp (condition-case lossage
|
||||
(org-velocity-generic-search
|
||||
search hide-hints)
|
||||
(invalid-regexp
|
||||
(minibuffer-message "%s" lossage))))))))
|
||||
(with-current-buffer (org-velocity-match-buffer)
|
||||
(goto-char (point-min)))))
|
||||
(with-current-buffer (org-velocity-match-buffer)
|
||||
(erase-buffer))))
|
||||
|
||||
(defun org-velocity-store-link ()
|
||||
"Function for `org-store-link-functions'."
|
||||
|
|
@ -443,72 +453,53 @@ that order. Which is preferred is determined by
|
|||
|
||||
(add-hook 'org-store-link-functions 'org-velocity-store-link)
|
||||
|
||||
(defun org-velocity-create (search &optional ask)
|
||||
(defun* org-velocity-create (search &key ask)
|
||||
"Create new heading named SEARCH.
|
||||
If ASK is non-nil, ask first."
|
||||
(when (or (null ask) (y-or-n-p "No match found, create? "))
|
||||
(let ((org-velocity-search search)
|
||||
(org-default-notes-file (org-velocity-use-file))
|
||||
(org-default-notes-file (org-velocity-bucket-file))
|
||||
;; save a stored link
|
||||
org-store-link-plist)
|
||||
(org-velocity-create-1))
|
||||
(org-velocity-capture))
|
||||
search))
|
||||
|
||||
(defun org-velocity-get-matches (search)
|
||||
"Return matches for SEARCH in current bucket.
|
||||
Use method specified by `org-velocity-search-method'."
|
||||
(when (and search (not (string-equal "" search)))
|
||||
(with-current-buffer (org-velocity-bucket-buffer)
|
||||
;; Fold case if the search string is lowercase.
|
||||
(let ((case-fold-search (equal search (downcase search))))
|
||||
(case org-velocity-search-method
|
||||
('phrase (org-velocity-phrase-search search))
|
||||
('any (org-velocity-any-search search))
|
||||
('all (org-velocity-all-search search))
|
||||
('regexp (org-velocity-regexp-search search)))))))
|
||||
|
||||
(defun org-velocity-engine (search)
|
||||
"Display a list of headings where SEARCH occurs."
|
||||
(with-current-buffer (org-velocity-display-buffer)
|
||||
(erase-buffer)
|
||||
(setq cursor-type nil))
|
||||
(unless (or
|
||||
(not (stringp search))
|
||||
(string-equal "" search)) ;exit on empty string
|
||||
(case
|
||||
(if (and org-velocity-force-new (eq last-command-event ?\C-j))
|
||||
'force
|
||||
(with-current-buffer (org-velocity-bucket-buffer)
|
||||
(save-excursion
|
||||
(let ((matches (org-velocity-get-matches search)))
|
||||
(org-velocity-present matches nil search)
|
||||
(cond ((zerop (length matches)) 'new)
|
||||
((= (length matches) 1) 'follow)
|
||||
((> (length matches) 1) 'prompt))))))
|
||||
('prompt (progn
|
||||
(Electric-pop-up-window (org-velocity-display-buffer))
|
||||
(let ((hint (org-velocity-electric-follow-hint)))
|
||||
(if hint
|
||||
(case hint
|
||||
(edit (org-velocity-read nil search))
|
||||
(force (org-velocity-create search))
|
||||
(otherwise (org-velocity-activate-button hint)))))))
|
||||
('new (unless (org-velocity-create search t)
|
||||
(org-velocity-read nil search)))
|
||||
('force (org-velocity-create search))
|
||||
('follow (if (y-or-n-p "One match, follow? ")
|
||||
(progn
|
||||
(set-buffer (org-velocity-display-buffer))
|
||||
(goto-char (point-min))
|
||||
(button-activate (next-button (point))))
|
||||
(org-velocity-read nil search))))))
|
||||
(let ((org-velocity-search search))
|
||||
(unless (or
|
||||
(not (stringp search))
|
||||
(string= "" search)) ;exit on empty string
|
||||
(case
|
||||
(if (and org-velocity-force-new (eq last-command-event ?\C-j))
|
||||
:force
|
||||
(let ((matches (org-velocity-present search)))
|
||||
(cond ((null matches) :new)
|
||||
((org-velocity-singlep matches) :follow)
|
||||
(t :prompt))))
|
||||
(:prompt (progn
|
||||
(pop-to-buffer (org-velocity-match-buffer))
|
||||
(let ((hint (org-velocity-electric-read-hint)))
|
||||
(when hint (case hint
|
||||
(:edit (org-velocity-read nil search))
|
||||
(:force (org-velocity-create search))
|
||||
(otherwise (org-velocity-activate-button hint)))))))
|
||||
(:new (unless (org-velocity-create search :ask t)
|
||||
(org-velocity-read nil search)))
|
||||
(:force (org-velocity-create search))
|
||||
(:follow (if (y-or-n-p "One match, follow? ")
|
||||
(progn
|
||||
(set-buffer (org-velocity-match-buffer))
|
||||
(goto-char (point-min))
|
||||
(button-activate (next-button (point))))
|
||||
(org-velocity-read nil search)))))))
|
||||
|
||||
(defun org-velocity-position (item list)
|
||||
"Return first position of ITEM in LIST."
|
||||
(loop for elt in list
|
||||
for i from 0
|
||||
if (equal elt item)
|
||||
return i))
|
||||
for i from 0
|
||||
when (equal elt item)
|
||||
return i))
|
||||
|
||||
(defun org-velocity-activate-button (char)
|
||||
"Go to button on line number associated with CHAR in `org-velocity-index'."
|
||||
|
|
@ -525,7 +516,11 @@ Use method specified by `org-velocity-search-method'."
|
|||
(interactive)
|
||||
(message "%s"
|
||||
(substitute-command-keys
|
||||
"\\[org-velocity-electric-new] for new entry, \\[org-velocity-electric-edit] to edit search, \\[scroll-up] to scroll."))
|
||||
"\\[org-velocity-electric-new] for new entry,
|
||||
\\[org-velocity-electric-edit] to edit search,
|
||||
\\[scroll-up] to scroll up,
|
||||
\\[scroll-down] to scroll down,
|
||||
\\[keyboard-quit] to quit."))
|
||||
(sit-for 4))
|
||||
|
||||
(defun org-velocity-electric-follow (ev)
|
||||
|
|
@ -548,12 +543,12 @@ Use method specified by `org-velocity-search-method'."
|
|||
(defun org-velocity-electric-edit ()
|
||||
"Edit the search string."
|
||||
(interactive)
|
||||
(throw 'org-velocity-select 'edit))
|
||||
(throw 'org-velocity-select :edit))
|
||||
|
||||
(defun org-velocity-electric-new ()
|
||||
"Force a new entry."
|
||||
(interactive)
|
||||
(throw 'org-velocity-select 'force))
|
||||
(throw 'org-velocity-select :force))
|
||||
|
||||
(defvar org-velocity-electric-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
|
|
@ -561,26 +556,28 @@ Use method specified by `org-velocity-search-method'."
|
|||
(loop for c in org-velocity-index
|
||||
do (define-key map (char-to-string c) 'org-velocity-electric-follow))
|
||||
(define-key map "0" 'org-velocity-electric-new)
|
||||
(define-key map [tab] 'scroll-up)
|
||||
(define-key map [return] 'org-velocity-electric-edit)
|
||||
(define-key map "\C-v" 'scroll-up)
|
||||
(define-key map "\M-v" 'scroll-down)
|
||||
(define-key map (kbd "RET") 'org-velocity-electric-edit)
|
||||
(define-key map [mouse-1] 'org-velocity-electric-click)
|
||||
(define-key map [mouse-2] 'org-velocity-electric-click)
|
||||
(define-key map [escape escape escape] 'keyboard-quit)
|
||||
(define-key map [escape] 'keyboard-quit)
|
||||
(define-key map "\C-h" 'help-command)
|
||||
map))
|
||||
|
||||
(defun org-velocity-electric-follow-hint ()
|
||||
(defun org-velocity-electric-read-hint ()
|
||||
"Read index of button electrically."
|
||||
(with-current-buffer (org-velocity-display-buffer)
|
||||
(with-current-buffer (org-velocity-match-buffer)
|
||||
(use-local-map org-velocity-electric-map)
|
||||
(catch 'org-velocity-select
|
||||
(Electric-command-loop 'org-velocity-select
|
||||
"Follow: "))))
|
||||
(Electric-command-loop 'org-velocity-select "Follow: "))))
|
||||
|
||||
(defvar org-velocity-incremental-keymap
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(define-key map [mouse-1] 'org-velocity-click-for-incremental)
|
||||
(define-key map [mouse-2] 'org-velocity-click-for-incremental)
|
||||
(define-key map "\C-v" 'scroll-up)
|
||||
(define-key map "\M-v" 'scroll-down)
|
||||
map))
|
||||
|
||||
(defun org-velocity-click-for-incremental ()
|
||||
|
|
@ -601,30 +598,24 @@ Use method specified by `org-velocity-search-method'."
|
|||
(eq (buffer-local-value 'major-mode (window-buffer w))
|
||||
'completion-list-mode))))
|
||||
|
||||
(defun org-velocity-display-for-incremental ()
|
||||
"Display results of search without hinting."
|
||||
(when (and (sit-for idle-update-delay)
|
||||
(not (org-velocity-displaying-completions-p)))
|
||||
(defun org-velocity-update ()
|
||||
"Display results of search without hinting.
|
||||
Stop searching once there are more matches than can be displayed."
|
||||
(unless (org-velocity-displaying-completions-p)
|
||||
(let* ((search (org-velocity-minibuffer-contents))
|
||||
(matches (org-velocity-get-matches search)))
|
||||
(if (zerop (length matches))
|
||||
(progn
|
||||
(when (get-buffer-window (org-velocity-display-buffer))
|
||||
(delete-window
|
||||
(get-buffer-window (org-velocity-display-buffer)))
|
||||
(select-window (active-minibuffer-window)))
|
||||
(unless (string-equal search "")
|
||||
(minibuffer-message "No match; RET to create")))
|
||||
(if (and org-velocity-exit-on-match
|
||||
(= (length matches) 1))
|
||||
(throw 'click search))
|
||||
(with-current-buffer (org-velocity-display-buffer)
|
||||
(use-local-map org-velocity-incremental-keymap)
|
||||
(erase-buffer)
|
||||
(setq cursor-type nil))
|
||||
(with-current-buffer (org-velocity-bucket-buffer)
|
||||
(org-velocity-present matches t search))
|
||||
(display-buffer (org-velocity-display-buffer))))))
|
||||
(matches (org-velocity-present search :hide-hints t)))
|
||||
(cond ((null matches)
|
||||
(select-window (active-minibuffer-window))
|
||||
(unless (or (null search) (string= "" search))
|
||||
(minibuffer-message "No match; RET to create")))
|
||||
((and (org-velocity-singlep matches)
|
||||
org-velocity-exit-on-match)
|
||||
(throw 'click search))
|
||||
(t
|
||||
(with-current-buffer (org-velocity-match-buffer)
|
||||
(use-local-map org-velocity-incremental-keymap)))))))
|
||||
|
||||
(defvar dabbrev--last-abbrev)
|
||||
|
||||
(defun org-velocity-dabbrev-completion-list (abbrev)
|
||||
"Return all dabbrev completions for ABBREV."
|
||||
|
|
@ -633,17 +624,25 @@ Use method specified by `org-velocity-search-method'."
|
|||
(setq dabbrev--last-abbrev abbrev)
|
||||
(dabbrev--find-all-expansions abbrev case-fold-search))
|
||||
|
||||
(defvar org-velocity-local-completion-map
|
||||
(let ((map (make-sparse-keymap)))
|
||||
(set-keymap-parent map minibuffer-local-completion-map)
|
||||
(define-key map " " 'self-insert-command)
|
||||
(define-key map [remap minibuffer-complete] 'minibuffer-complete-word)
|
||||
map)
|
||||
"Keymap for completion with `completing-read'.")
|
||||
|
||||
(defun org-velocity-read-with-completion (prompt)
|
||||
"Completing read with PROMPT."
|
||||
(let ((minibuffer-local-completion-map
|
||||
minibuffer-local-filename-completion-map)
|
||||
org-velocity-local-completion-map)
|
||||
(completion-no-auto-exit t)
|
||||
(crm-separator " "))
|
||||
(funcall
|
||||
(case org-velocity-search-method
|
||||
(phrase 'completing-read)
|
||||
(any 'completing-read-multiple)
|
||||
(all 'completing-read-multiple))
|
||||
(phrase #'completing-read)
|
||||
(any #'completing-read-multiple)
|
||||
(all #'completing-read-multiple))
|
||||
prompt
|
||||
(completion-table-dynamic
|
||||
'org-velocity-dabbrev-completion-list))))
|
||||
|
|
@ -660,30 +659,36 @@ Use method specified by `org-velocity-search-method'."
|
|||
(goto-char (point-max))))
|
||||
(if (eq org-velocity-search-method 'regexp)
|
||||
(read-regexp prompt)
|
||||
(if (and org-velocity-use-completion
|
||||
;; map-entries complains for nonexistent files
|
||||
(file-exists-p (org-velocity-use-file)))
|
||||
(if org-velocity-use-completion
|
||||
(org-velocity-read-with-completion prompt)
|
||||
(read-string prompt)))))
|
||||
|
||||
(defun org-velocity-read-incrementally (prompt)
|
||||
(defun org-velocity-incremental-read (prompt)
|
||||
"Read string with PROMPT and display results incrementally."
|
||||
(let ((res
|
||||
(unwind-protect
|
||||
(catch 'click
|
||||
(add-hook 'post-command-hook
|
||||
'org-velocity-display-for-incremental)
|
||||
(if (eq org-velocity-search-method 'regexp)
|
||||
(read-regexp prompt)
|
||||
(if (and org-velocity-use-completion
|
||||
(file-exists-p (org-velocity-use-file)))
|
||||
(org-velocity-read-with-completion prompt)
|
||||
(read-string prompt))))
|
||||
(remove-hook 'post-command-hook
|
||||
'org-velocity-display-for-incremental))))
|
||||
(let* ((match-window (display-buffer (org-velocity-match-buffer)))
|
||||
(org-velocity-index
|
||||
;; Truncate the index to the size of the buffer to be
|
||||
;; displayed.
|
||||
(with-selected-window match-window
|
||||
(if (> (window-height) (length org-velocity-index))
|
||||
;; (subseq org-velocity-index 0 (window-height))
|
||||
(let ((hints (copy-sequence org-velocity-index)))
|
||||
(setcdr (nthcdr (window-height) hints) nil)
|
||||
hints)
|
||||
org-velocity-index))))
|
||||
(catch 'click
|
||||
(add-hook 'post-command-hook 'org-velocity-update)
|
||||
(if (eq org-velocity-search-method 'regexp)
|
||||
(read-regexp prompt)
|
||||
(if org-velocity-use-completion
|
||||
(org-velocity-read-with-completion prompt)
|
||||
(read-string prompt)))))
|
||||
(remove-hook 'post-command-hook 'org-velocity-update))))
|
||||
(if (bufferp res) (org-pop-to-buffer-same-window res) res)))
|
||||
|
||||
(defun org-velocity-read (arg &optional search)
|
||||
(defun org-velocity (arg &optional search)
|
||||
"Read a search string SEARCH for Org-Velocity interface.
|
||||
This means that a buffer will display all headings where SEARCH
|
||||
occurs, where one can be selected by a mouse click or by typing
|
||||
|
|
@ -693,22 +698,26 @@ created named SEARCH.
|
|||
If `org-velocity-bucket' is defined and
|
||||
`org-velocity-always-use-bucket' is non-nil, then the bucket file
|
||||
will be used; otherwise, this will work when called in any Org
|
||||
file. Calling with ARG forces current file."
|
||||
file. Calling with ARG forces current file."
|
||||
(interactive "P")
|
||||
(let ((org-velocity-always-use-bucket
|
||||
(if arg nil org-velocity-always-use-bucket)))
|
||||
;; complain if inappropriate
|
||||
(assert (org-velocity-use-file))
|
||||
(unwind-protect
|
||||
(let ((dabbrev-search-these-buffers-only
|
||||
(list (org-velocity-bucket-buffer))))
|
||||
(org-velocity-engine
|
||||
(if org-velocity-search-is-incremental
|
||||
(org-velocity-read-incrementally "Velocity search: ")
|
||||
(org-velocity-read-string "Velocity search: " search))))
|
||||
(progn
|
||||
(kill-buffer (org-velocity-display-buffer))
|
||||
(delete-other-windows)))))
|
||||
(assert (org-velocity-bucket-file))
|
||||
(let ((org-velocity-bucket-buffer
|
||||
(find-file-noselect (org-velocity-bucket-file))))
|
||||
(unwind-protect
|
||||
(let ((dabbrev-search-these-buffers-only
|
||||
(list (org-velocity-bucket-buffer))))
|
||||
(org-velocity-engine
|
||||
(if org-velocity-search-is-incremental
|
||||
(org-velocity-incremental-read "Velocity search: ")
|
||||
(org-velocity-read-string "Velocity search: " search))))
|
||||
(progn
|
||||
(kill-buffer (org-velocity-match-buffer))
|
||||
(delete-other-windows))))))
|
||||
|
||||
(defalias 'org-velocity-read 'org-velocity)
|
||||
|
||||
(provide 'org-velocity)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue