Merge branch 'maint'
[org-mode.git] / contrib / lisp / org-velocity.el
blob7425d32af161e2564c60944410146bc78b7ff801
1 ;;; org-velocity.el --- something like Notational Velocity for Org.
3 ;; Copyright (C) 2010-2012 Paul M. Rodriguez
5 ;; Author: Paul M. Rodriguez <paulmrodriguez@gmail.com>
6 ;; Created: 2010-05-05
7 ;; Version: 3.0
9 ;; This file is not part of GNU Emacs.
11 ;; This program is free software; you can redistribute it and/or
12 ;; modify it under the terms of the GNU General Public License as
13 ;; published by the Free Software Foundation version 2.
15 ;; This program is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
20 ;; For a copy of the GNU General Public License, search the Internet,
21 ;; or write to the Free Software Foundation, Inc., 59 Temple Place,
22 ;; Suite 330, Boston, MA 02111-1307 USA
24 ;;; Commentary:
25 ;; Org-Velocity.el is an interface for Org inspired by the minimalist
26 ;; notetaking program Notational Velocity. The idea is to let you
27 ;; amass and access brief notes on many subjects with minimal fuss.
28 ;; Each note is an entry in an ordinary Org file.
30 ;; Org-Velocity can be used in two ways: when called outside Org, to
31 ;; store and access notes in a designated bucket file; or, when called
32 ;; inside Org, as a method for navigating any Org file. (Setting the
33 ;; option `org-velocity-always-use-bucket' disables navigation inside
34 ;; Org files by default, although you can still force this behavior by
35 ;; calling `org-velocity-read' with an argument.)
37 ;; Org-Velocity prompts for search terms in the minibuffer. A list of
38 ;; headings of entries whose text matches your search is updated as
39 ;; you type; you can end the search and visit an entry at any time by
40 ;; clicking on its heading.
42 ;; RET displays the results. If there are no matches, Org-Velocity
43 ;; offers to create a new entry with your search string as its
44 ;; heading. If there are matches, it displays a list of results where
45 ;; the heading of each matching entry is hinted with a number or
46 ;; letter; clicking a result, or typing the matching hint, opens the
47 ;; entry for editing in an indirect buffer. 0 forces a new entry; RET
48 ;; reopens the search for editing.
50 ;; You can customize every step in this process, including the search
51 ;; method, completion for search terms, and templates for creating new
52 ;; entries; M-x customize-group RET org-velocity RET to see all the
53 ;; options.
55 ;; Thanks to Richard Riley, Carsten Dominik, Bastien Guerry, and Jeff
56 ;; Horn for their suggestions.
58 ;;; Usage:
59 ;; (require 'org-velocity)
60 ;; (setq org-velocity-bucket (expand-file-name "bucket.org" org-directory))
61 ;; (global-set-key (kbd "C-c v") 'org-velocity)
63 ;;; Code:
64 (require 'org)
65 (require 'button)
66 (require 'electric)
67 (require 'dabbrev)
68 (eval-when-compile (require 'cl))
70 (defgroup org-velocity nil
71 "Notational Velocity-style interface for Org."
72 :tag "Org-Velocity"
73 :group 'outlines
74 :group 'hypermedia
75 :group 'org)
77 (defcustom org-velocity-bucket ""
78 "Where is the bucket file?"
79 :group 'org-velocity
80 :type 'file)
82 (defcustom org-velocity-search-is-incremental t
83 "Show results incrementally when possible?"
84 :group 'org-velocity
85 :type 'boolean
86 :safe 'booleanp)
88 (defcustom org-velocity-show-previews t
89 "Show previews of the text of each heading?"
90 :group 'velocity
91 :type 'boolean
92 :safe 'booleanp)
94 (defcustom org-velocity-exit-on-match nil
95 "When searching incrementally, exit on a single match?"
96 :group 'org-velocity
97 :type 'boolean
98 :safe 'booleanp)
100 (defcustom org-velocity-force-new nil
101 "Should exiting the minibuffer with C-j force a new entry?"
102 :group 'org-velocity
103 :type 'boolean
104 :safe 'booleanp)
106 (defcustom org-velocity-use-search-ring t
107 "Push search to `search-ring' when visiting an entry?
109 This means that C-s C-s will take you directly to the first
110 instance of the search string."
111 :group 'org-velocity
112 :type 'boolean
113 :safe 'booleanp)
115 (defcustom org-velocity-always-use-bucket nil
116 "Use bucket file even when called from an Org buffer?"
117 :group 'org-velocity
118 :type 'boolean
119 :safe 'booleanp)
121 (defcustom org-velocity-use-completion nil
122 "Use completion?
124 Notwithstanding the value of this option, calling
125 `dabbrev-expand' always completes against the text of the bucket
126 file."
127 :group 'org-velocity
128 :type '(choice
129 (const :tag "Do not use completion" nil)
130 (const :tag "Use completion" t))
131 :safe 'booleanp)
133 (defcustom org-velocity-search-method 'phrase
134 "Match on whole phrase, any word, or all words?"
135 :group 'org-velocity
136 :type '(choice
137 (const :tag "Match whole phrase" phrase)
138 (const :tag "Match any word" any)
139 (const :tag "Match all words" all)
140 (const :tag "Match a regular expression" regexp))
141 :safe (lambda (v) (memq v '(phrase any all regexp))))
143 (defcustom org-velocity-capture-templates
144 '(("v"
145 "Velocity entry"
146 entry
147 (file "")
148 "* %:search\n\n%i%?"))
149 "Use these template with `org-capture'.
150 Meanwhile `org-default-notes-file' is bound to `org-velocity-bucket-file'.
151 The keyword :search inserts the current search.
152 See the documentation for `org-capture-templates'."
153 :group 'org-velocity
154 :type (or (get 'org-capture-templates 'custom-type) 'list))
156 (defsubst org-velocity-grab-preview ()
157 "Grab preview of a subtree.
158 The length of the preview is determined by `window-width'.
160 Replace all contiguous whitespace with single spaces."
161 (let ((start (progn
162 (forward-line 1)
163 (if (looking-at org-property-start-re)
164 (re-search-forward org-property-end-re)
165 (1- (point))))))
166 (mapconcat
167 #'identity
168 (split-string
169 (buffer-substring-no-properties
170 start
171 (min
172 (+ start (window-width))
173 (point-max))))
174 " ")))
176 (defstruct org-velocity-heading buffer position name level preview)
178 (defsubst org-velocity-nearest-heading (position)
179 "Return last heading at POSITION.
180 If there is no last heading, return nil."
181 (save-excursion
182 (goto-char position)
183 (re-search-backward org-velocity-heading-regexp)
184 (let ((components (org-heading-components)))
185 (make-org-velocity-heading
186 :buffer (current-buffer)
187 :position (point)
188 :name (nth 4 components)
189 :level (nth 0 components)
190 :preview (if org-velocity-show-previews
191 (org-velocity-grab-preview))))))
193 (defconst org-velocity-index
194 (eval-when-compile
195 (nconc (number-sequence 49 57) ;numbers
196 (number-sequence 97 122) ;lowercase letters
197 (number-sequence 65 90))) ;uppercase letters
198 "List of chars for indexing results.")
200 (defconst org-velocity-match-buffer-name "*Velocity matches*")
202 (defconst org-velocity-heading-regexp "^\\* "
203 "Regexp to match only top-level headings.")
205 (defvar org-velocity-search nil
206 "Variable to bind to current search.")
208 (defun org-velocity-buffer-file-name (&optional buffer)
209 "Return the name of the file BUFFER saves to.
210 Same as function `buffer-file-name' unless BUFFER is an indirect
211 buffer or a minibuffer. In the former case, return the file name
212 of the base buffer; in the latter, return the file name of
213 `minibuffer-selected-window' (or its base buffer)."
214 (let ((buffer (if (minibufferp buffer)
215 (window-buffer (minibuffer-selected-window))
216 buffer)))
217 (buffer-file-name
218 (or (buffer-base-buffer buffer)
219 buffer))))
221 (defun org-velocity-minibuffer-contents ()
222 "Return the contents of the minibuffer when it is active."
223 (if (active-minibuffer-window)
224 (with-current-buffer (window-buffer (active-minibuffer-window))
225 (minibuffer-contents))))
227 (defsubst org-velocity-singlep (object)
228 "Return t when OBJECT is a list or sequence of one element."
229 (if (consp object)
230 (null (cdr object))
231 (= (length object) 1)))
233 (defun org-velocity-bucket-file ()
234 "Return the proper file for Org-Velocity to search.
235 If `org-velocity-always-use-bucket' is t, use bucket file;
236 complain if missing. Otherwise, if an Org file is current, then
237 use it."
238 (let ((org-velocity-bucket
239 (when org-velocity-bucket (expand-file-name org-velocity-bucket)))
240 (buffer
241 (let ((buffer-file (org-velocity-buffer-file-name)))
242 (when buffer-file
243 ;; Use the target in capture buffers.
244 (org-find-base-buffer-visiting buffer-file)))))
245 (if org-velocity-always-use-bucket
246 (or org-velocity-bucket (error "Bucket required but not defined"))
247 (if (and (eq (buffer-local-value 'major-mode (or buffer (current-buffer)))
248 'org-mode)
249 (org-velocity-buffer-file-name))
250 (org-velocity-buffer-file-name)
251 (or org-velocity-bucket
252 (error "No bucket and not an Org file"))))))
254 (defvar org-velocity-bucket-buffer nil)
256 (defsubst org-velocity-bucket-buffer ()
257 (or org-velocity-bucket-buffer
258 (find-file-noselect (org-velocity-bucket-file))))
260 (defsubst org-velocity-match-buffer ()
261 "Return the proper buffer for Org-Velocity to display in."
262 (get-buffer-create org-velocity-match-buffer-name))
264 (defun org-velocity-beginning-of-headings ()
265 "Goto the start of the first heading."
266 (goto-char (point-min))
267 ;; If we are before the first heading we could still be at the
268 ;; first heading.
269 (or (looking-at org-velocity-heading-regexp)
270 (re-search-forward org-velocity-heading-regexp)))
272 (defun org-velocity-make-indirect-buffer (heading)
273 "Make or switch to an indirect buffer visiting HEADING."
275 (let* ((bucket (org-velocity-heading-buffer heading))
276 (name (org-velocity-heading-name heading))
277 (existing (get-buffer name)))
278 (if (and existing (buffer-base-buffer existing)
279 (equal (buffer-base-buffer existing) bucket))
280 existing
281 (make-indirect-buffer
282 bucket
283 (generate-new-buffer-name (org-velocity-heading-name heading))))))
285 (defun org-velocity-capture ()
286 "Record a note with `org-capture'."
287 (let ((org-capture-templates
288 org-velocity-capture-templates))
289 (org-capture nil
290 ;; This is no longer automatically selected.
291 (when (org-velocity-singlep org-capture-templates)
292 (caar org-capture-templates)))
293 (if org-capture-mode (rename-buffer org-velocity-search t))))
295 (defvar org-velocity-saved-winconf nil)
296 (make-variable-buffer-local 'org-velocity-saved-winconf)
298 (defun org-velocity-edit-entry (heading)
299 "Edit entry at HEADING in an indirect buffer."
300 (let ((winconf (current-window-configuration)))
301 (let ((buffer (org-velocity-make-indirect-buffer heading)))
302 (with-current-buffer buffer
303 (let ((org-inhibit-startup t))
304 (org-mode))
305 (setq org-velocity-saved-winconf winconf)
306 (goto-char (org-velocity-heading-position heading))
307 (narrow-to-region (point)
308 (save-excursion
309 (org-end-of-subtree t)
310 (point)))
311 (goto-char (point-min))
312 (add-hook 'org-ctrl-c-ctrl-c-hook 'org-velocity-dismiss nil t))
313 (pop-to-buffer buffer)
314 (set (make-local-variable 'header-line-format)
315 (format "%s Use C-c C-c to finish."
316 (abbreviate-file-name
317 (buffer-file-name
318 (org-velocity-heading-buffer heading))))))))
320 (defun org-velocity-dismiss ()
321 "Save current entry and close indirect buffer."
322 (let ((winconf org-velocity-saved-winconf))
323 (prog1 t ;Tell hook we're done.
324 (save-buffer)
325 (kill-buffer)
326 (when (window-configuration-p winconf)
327 (set-window-configuration winconf)))))
329 (defun org-velocity-visit-button (button)
330 (run-hooks 'mouse-leave-buffer-hook)
331 (if org-velocity-use-search-ring
332 (add-to-history 'search-ring
333 (button-get button 'search)
334 search-ring-max))
335 (org-velocity-edit-entry (button-get button 'match)))
337 (define-button-type 'org-velocity-button
338 'action #'org-velocity-visit-button)
340 (defsubst org-velocity-buttonize (heading)
341 "Insert HEADING as a text button with no hints."
342 (insert-text-button
343 (propertize (org-velocity-heading-name heading) 'face 'link)
344 :type 'org-velocity-button
345 'match heading
346 'search org-velocity-search))
348 (defsubst org-velocity-insert-preview (heading)
349 (when org-velocity-show-previews
350 (insert-char ?\ 1)
351 (insert
352 (propertize
353 (org-velocity-heading-preview heading)
354 'face 'shadow))))
356 (defsubst* org-velocity-present-match (&key hint match)
357 (with-current-buffer (org-velocity-match-buffer)
358 (when hint (insert "#" hint " "))
359 (org-velocity-buttonize match)
360 (org-velocity-insert-preview match)
361 (newline)))
363 (defun org-velocity-generic-search (search &optional hide-hints)
364 "Display any entry containing SEARCH."
365 (let ((hints org-velocity-index) matches)
366 (block nil
367 (while (and hints (re-search-forward search nil t))
368 (let ((match (org-velocity-nearest-heading (point))))
369 (org-velocity-present-match
370 :hint (unless hide-hints (car hints))
371 :match match)
372 (push match matches))
373 (setq hints (cdr hints))
374 (unless (re-search-forward org-velocity-heading-regexp nil t)
375 (return))))
376 (nreverse matches)))
378 (defun* org-velocity-all-search (search &optional hide-hints max)
379 "Display only entries containing every word in SEARCH."
380 (let ((keywords (mapcar 'regexp-quote (split-string search)))
381 (hints org-velocity-index)
382 matches)
383 (org-map-entries
384 (lambda ()
385 ;; Return if we've run out of hints.
386 (when (null hints)
387 (return-from org-velocity-all-search (nreverse matches)))
388 ;; Only search the subtree once.
389 (setq org-map-continue-from
390 (save-excursion
391 (goto-char (line-end-position))
392 (if (re-search-forward org-velocity-heading-regexp nil t)
393 (line-end-position)
394 (point-max))))
395 (when (loop for word in keywords
396 always (save-excursion
397 (re-search-forward
398 (concat "\\<" word "\\>")
399 org-map-continue-from t)))
400 (let ((match (org-velocity-nearest-heading (match-end 0))))
401 (org-velocity-present-match
402 :hint (unless hide-hints (car hints))
403 :match match)
404 (push match matches)
405 (setq hints (cdr hints))))))
406 (nreverse matches)))
408 (defun* org-velocity-present (search &key hide-hints)
409 "Buttonize matches for SEARCH in `org-velocity-match-buffer'.
410 If HIDE-HINTS is non-nil, display entries without indices. SEARCH
411 binds `org-velocity-search'.
413 Return matches."
414 (if (and (stringp search) (not (string= "" search)))
415 ;; Fold case when the search string is all lowercase.
416 (let ((case-fold-search (equal search (downcase search)))
417 (truncate-partial-width-windows t))
418 (with-current-buffer (org-velocity-match-buffer)
419 (erase-buffer)
420 ;; Permanent locals.
421 (setq cursor-type nil
422 truncate-lines t))
423 (prog1
424 (with-current-buffer (org-velocity-bucket-buffer)
425 (let ((inhibit-point-motion-hooks t)
426 (inhibit-field-text-motion t))
427 (save-excursion
428 (org-velocity-beginning-of-headings)
429 (case org-velocity-search-method
430 (all (org-velocity-all-search search hide-hints))
431 (phrase (org-velocity-generic-search
432 (concat "\\<" (regexp-quote search))
433 hide-hints))
434 (any (org-velocity-generic-search
435 (concat "\\<"
436 (regexp-opt (split-string search)))
437 hide-hints))
438 (regexp (condition-case lossage
439 (org-velocity-generic-search
440 search hide-hints)
441 (invalid-regexp
442 (minibuffer-message "%s" lossage))))))))
443 (with-current-buffer (org-velocity-match-buffer)
444 (goto-char (point-min)))))
445 (with-current-buffer (org-velocity-match-buffer)
446 (erase-buffer))))
448 (defun org-velocity-store-link ()
449 "Function for `org-store-link-functions'."
450 (if org-velocity-search
451 (org-store-link-props
452 :search org-velocity-search)))
454 (add-hook 'org-store-link-functions 'org-velocity-store-link)
456 (defun* org-velocity-create (search &key ask)
457 "Create new heading named SEARCH.
458 If ASK is non-nil, ask first."
459 (when (or (null ask) (y-or-n-p "No match found, create? "))
460 (let ((org-velocity-search search)
461 (org-default-notes-file (org-velocity-bucket-file))
462 ;; save a stored link
463 org-store-link-plist)
464 (org-velocity-capture))
465 search))
467 (defun org-velocity-engine (search)
468 "Display a list of headings where SEARCH occurs."
469 (let ((org-velocity-search search))
470 (unless (or
471 (not (stringp search))
472 (string= "" search)) ;exit on empty string
473 (case
474 (if (and org-velocity-force-new (eq last-command-event ?\C-j))
475 :force
476 (let ((matches (org-velocity-present search)))
477 (cond ((null matches) :new)
478 ((org-velocity-singlep matches) :follow)
479 (t :prompt))))
480 (:prompt (progn
481 (pop-to-buffer (org-velocity-match-buffer))
482 (let ((hint (org-velocity-electric-read-hint)))
483 (when hint (case hint
484 (:edit (org-velocity-read nil search))
485 (:force (org-velocity-create search))
486 (otherwise (org-velocity-activate-button hint)))))))
487 (:new (unless (org-velocity-create search :ask t)
488 (org-velocity-read nil search)))
489 (:force (org-velocity-create search))
490 (:follow (if (y-or-n-p "One match, follow? ")
491 (progn
492 (set-buffer (org-velocity-match-buffer))
493 (goto-char (point-min))
494 (button-activate (next-button (point))))
495 (org-velocity-read nil search)))))))
497 (defun org-velocity-position (item list)
498 "Return first position of ITEM in LIST."
499 (loop for elt in list
500 for i from 0
501 when (equal elt item)
502 return i))
504 (defun org-velocity-activate-button (char)
505 "Go to button on line number associated with CHAR in `org-velocity-index'."
506 (goto-char (point-min))
507 (forward-line (org-velocity-position char org-velocity-index))
508 (goto-char
509 (button-start
510 (next-button (point))))
511 (message "%s" (button-label (button-at (point))))
512 (button-activate (button-at (point))))
514 (defun org-velocity-electric-undefined ()
515 "Complain about an undefined key."
516 (interactive)
517 (message "%s"
518 (substitute-command-keys
519 "\\[org-velocity-electric-new] for new entry,
520 \\[org-velocity-electric-edit] to edit search,
521 \\[scroll-up] to scroll up,
522 \\[scroll-down] to scroll down,
523 \\[keyboard-quit] to quit."))
524 (sit-for 4))
526 (defun org-velocity-electric-follow (ev)
527 "Follow a hint indexed by keyboard event EV."
528 (interactive (list last-command-event))
529 (if (not (> (org-velocity-position ev org-velocity-index)
530 (1- (count-lines (point-min) (point-max)))))
531 (throw 'org-velocity-select ev)
532 (call-interactively 'org-velocity-electric-undefined)))
534 (defun org-velocity-electric-click (ev)
535 "Follow hint indexed by a mouse event EV."
536 (interactive "e")
537 (throw 'org-velocity-select
538 (nth (1- (count-lines
539 (point-min)
540 (posn-point (event-start ev))))
541 org-velocity-index)))
543 (defun org-velocity-electric-edit ()
544 "Edit the search string."
545 (interactive)
546 (throw 'org-velocity-select :edit))
548 (defun org-velocity-electric-new ()
549 "Force a new entry."
550 (interactive)
551 (throw 'org-velocity-select :force))
553 (defvar org-velocity-electric-map
554 (let ((map (make-sparse-keymap)))
555 (define-key map [t] 'org-velocity-electric-undefined)
556 (loop for c in org-velocity-index
557 do (define-key map (char-to-string c) 'org-velocity-electric-follow))
558 (define-key map "0" 'org-velocity-electric-new)
559 (define-key map "\C-v" 'scroll-up)
560 (define-key map "\M-v" 'scroll-down)
561 (define-key map (kbd "RET") 'org-velocity-electric-edit)
562 (define-key map [mouse-1] 'org-velocity-electric-click)
563 (define-key map [mouse-2] 'org-velocity-electric-click)
564 (define-key map [escape] 'keyboard-quit)
565 (define-key map "\C-h" 'help-command)
566 map))
568 (defun org-velocity-electric-read-hint ()
569 "Read index of button electrically."
570 (with-current-buffer (org-velocity-match-buffer)
571 (use-local-map org-velocity-electric-map)
572 (catch 'org-velocity-select
573 (Electric-command-loop 'org-velocity-select "Follow: "))))
575 (defvar org-velocity-incremental-keymap
576 (let ((map (make-sparse-keymap)))
577 (define-key map [mouse-1] 'org-velocity-click-for-incremental)
578 (define-key map [mouse-2] 'org-velocity-click-for-incremental)
579 (define-key map "\C-v" 'scroll-up)
580 (define-key map "\M-v" 'scroll-down)
581 map))
583 (defun org-velocity-click-for-incremental ()
584 "Jump out of search and select hint clicked on."
585 (interactive)
586 (let ((ev last-command-event))
587 (org-velocity-activate-button
588 (nth (- (count-lines
589 (point-min)
590 (posn-point (event-start ev))) 2)
591 org-velocity-index)))
592 (throw 'click (current-buffer)))
594 (defun org-velocity-displaying-completions-p ()
595 "Is there a *Completions* buffer showing?"
596 (get-window-with-predicate
597 (lambda (w)
598 (eq (buffer-local-value 'major-mode (window-buffer w))
599 'completion-list-mode))))
601 (defun org-velocity-update ()
602 "Display results of search without hinting.
603 Stop searching once there are more matches than can be displayed."
604 (unless (org-velocity-displaying-completions-p)
605 (let* ((search (org-velocity-minibuffer-contents))
606 (matches (org-velocity-present search :hide-hints t)))
607 (cond ((null matches)
608 (select-window (active-minibuffer-window))
609 (unless (or (null search) (string= "" search))
610 (minibuffer-message "No match; RET to create")))
611 ((and (org-velocity-singlep matches)
612 org-velocity-exit-on-match)
613 (throw 'click search))
615 (with-current-buffer (org-velocity-match-buffer)
616 (use-local-map org-velocity-incremental-keymap)))))))
618 (defvar dabbrev--last-abbrev)
620 (defun org-velocity-dabbrev-completion-list (abbrev)
621 "Return all dabbrev completions for ABBREV."
622 ;; This is based on `dabbrev-completion'.
623 (dabbrev--reset-global-variables)
624 (setq dabbrev--last-abbrev abbrev)
625 (dabbrev--find-all-expansions abbrev case-fold-search))
627 (defvar org-velocity-local-completion-map
628 (let ((map (make-sparse-keymap)))
629 (set-keymap-parent map minibuffer-local-completion-map)
630 (define-key map " " 'self-insert-command)
631 (define-key map [remap minibuffer-complete] 'minibuffer-complete-word)
632 map)
633 "Keymap for completion with `completing-read'.")
635 (defun org-velocity-read-with-completion (prompt)
636 "Completing read with PROMPT."
637 (let ((minibuffer-local-completion-map
638 org-velocity-local-completion-map)
639 (completion-no-auto-exit t)
640 (crm-separator " "))
641 (funcall
642 (case org-velocity-search-method
643 (phrase #'completing-read)
644 (any #'completing-read-multiple)
645 (all #'completing-read-multiple))
646 prompt
647 (completion-table-dynamic
648 'org-velocity-dabbrev-completion-list))))
650 (defun org-velocity-read-string (prompt &optional initial-input)
651 "Read string with PROMPT followed by INITIAL-INPUT."
652 ;; The use of initial inputs to the minibuffer is deprecated (see
653 ;; `read-from-minibuffer'), but in this case it is the user-friendly
654 ;; thing to do.
655 (minibuffer-with-setup-hook
656 (lexical-let ((initial-input initial-input))
657 (lambda ()
658 (and initial-input (insert initial-input))
659 (goto-char (point-max))))
660 (if (eq org-velocity-search-method 'regexp)
661 (read-regexp prompt)
662 (if org-velocity-use-completion
663 (org-velocity-read-with-completion prompt)
664 (read-string prompt)))))
666 (defun org-velocity-incremental-read (prompt)
667 "Read string with PROMPT and display results incrementally."
668 (let ((res
669 (unwind-protect
670 (let* ((match-window (display-buffer (org-velocity-match-buffer)))
671 (org-velocity-index
672 ;; Truncate the index to the size of the buffer to be
673 ;; displayed.
674 (with-selected-window match-window
675 (if (> (window-height) (length org-velocity-index))
676 ;; (subseq org-velocity-index 0 (window-height))
677 (let ((hints (copy-sequence org-velocity-index)))
678 (setcdr (nthcdr (window-height) hints) nil)
679 hints)
680 org-velocity-index))))
681 (catch 'click
682 (add-hook 'post-command-hook 'org-velocity-update)
683 (if (eq org-velocity-search-method 'regexp)
684 (read-regexp prompt)
685 (if org-velocity-use-completion
686 (org-velocity-read-with-completion prompt)
687 (read-string prompt)))))
688 (remove-hook 'post-command-hook 'org-velocity-update))))
689 (if (bufferp res) (org-pop-to-buffer-same-window res) res)))
691 (defun org-velocity (arg &optional search)
692 "Read a search string SEARCH for Org-Velocity interface.
693 This means that a buffer will display all headings where SEARCH
694 occurs, where one can be selected by a mouse click or by typing
695 its index. If SEARCH does not occur, then a new heading may be
696 created named SEARCH.
698 If `org-velocity-bucket' is defined and
699 `org-velocity-always-use-bucket' is non-nil, then the bucket file
700 will be used; otherwise, this will work when called in any Org
701 file. Calling with ARG forces current file."
702 (interactive "P")
703 (let ((org-velocity-always-use-bucket
704 (if arg nil org-velocity-always-use-bucket)))
705 ;; complain if inappropriate
706 (assert (org-velocity-bucket-file))
707 (let ((org-velocity-bucket-buffer
708 (find-file-noselect (org-velocity-bucket-file))))
709 (unwind-protect
710 (let ((dabbrev-search-these-buffers-only
711 (list (org-velocity-bucket-buffer))))
712 (org-velocity-engine
713 (if org-velocity-search-is-incremental
714 (org-velocity-incremental-read "Velocity search: ")
715 (org-velocity-read-string "Velocity search: " search))))
716 (progn
717 (kill-buffer (org-velocity-match-buffer))
718 (delete-other-windows))))))
720 (defalias 'org-velocity-read 'org-velocity)
722 (provide 'org-velocity)
724 ;;; org-velocity.el ends here