/[emacs]/emacs/lisp/filecache.el
ViewVC logotype

Annotation of /emacs/lisp/filecache.el

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.21 - (hide annotations) (download)
Mon Feb 16 13:36:12 2004 UTC (20 years, 3 months ago) by uid65627
Branch: MAIN
CVS Tags: gnus-5_10-pre-merge-yamaoka, gnus-5_10-post-merge-josefsson, gnus-5_10-pre-merge-josefsson, gnus-5_10-post-merge-yamaoka, after-merge-gnus-5_10, handa-temp-tag, gnus-5_10-branchpoint, before-merge-gnus-5_10
Branch point for: gnus-5_10-branch
Changes since 1.20: +7 -6 lines
All message and error commands now use prefix `filecache:'
to make it easy to read *Messages* buffer.

1 pj 1.14 ;;; filecache.el --- find files using a pre-loaded cache
2 rms 1.1 ;;
3 rms 1.5 ;; Author: Peter Breton <pbreton@cs.umb.edu>
4 rms 1.1 ;; Created: Sun Nov 10 1996
5 done 1.6 ;; Keywords: convenience
6 rms 1.1 ;;
7 miles 1.12 ;; Copyright (C) 1996, 2000 Free Software Foundation, Inc.
8 rms 1.2
9     ;; This file is part of GNU Emacs.
10    
11     ;; GNU Emacs is free software; you can redistribute it and/or modify
12 rms 1.1 ;; it under the terms of the GNU General Public License as published by
13     ;; the Free Software Foundation; either version 2, or (at your option)
14     ;; any later version.
15 rms 1.2
16     ;; GNU Emacs is distributed in the hope that it will be useful,
17 rms 1.1 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 rms 1.2 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19     ;; GNU General Public License for more details.
20    
21 rms 1.1 ;; You should have received a copy of the GNU General Public License
22 rms 1.2 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23     ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24     ;; Boston, MA 02111-1307, USA.
25    
26 rms 1.1 ;;; Commentary:
27     ;;
28     ;; The file-cache package is an attempt to make it easy to locate files
29     ;; by name, without having to remember exactly where they are located.
30     ;; This is very handy when working with source trees. You can also add
31     ;; frequently used files to the cache to create a hotlist effect.
32     ;; The cache can be used with any interactive command which takes a
33     ;; filename as an argument.
34     ;;
35     ;; It is worth noting that this package works best when most of the files
36     ;; in the cache have unique names, or (if they have the same name) exist in
37     ;; only a few directories. The worst case is many files all with
38     ;; the same name and in different directories, for example a big source tree
39     ;; with a Makefile in each directory. In such a case, you should probably
40     ;; use an alternate strategy to find the files.
41     ;;
42     ;; ADDING FILES TO THE CACHE:
43     ;;
44     ;; Use the following functions to add items to the file cache:
45 pbreton 1.9 ;;
46 rms 1.1 ;; * `file-cache-add-file': Adds a single file to the cache
47     ;;
48     ;; * `file-cache-add-file-list': Adds a list of files to the cache
49     ;;
50     ;; The following functions use the regular expressions in
51     ;; `file-cache-delete-regexps' to eliminate unwanted files:
52 pbreton 1.9 ;;
53 rms 1.1 ;; * `file-cache-add-directory': Adds the files in a directory to the
54     ;; cache. You can also specify a regular expression to match the files
55     ;; which should be added.
56     ;;
57     ;; * `file-cache-add-directory-list': Same as above, but acts on a list
58     ;; of directories. You can use `load-path', `exec-path' and the like.
59     ;;
60     ;; * `file-cache-add-directory-using-find': Uses the `find' command to
61     ;; add a directory tree to the cache.
62     ;;
63     ;; * `file-cache-add-directory-using-locate': Uses the `locate' command to
64     ;; add files matching a pattern to the cache.
65     ;;
66 pbreton 1.16 ;; * `file-cache-add-directory-recursively': Uses the find-lisp package to
67     ;; add all files matching a pattern to the cache.
68     ;;
69 rms 1.1 ;; Use the function `file-cache-clear-cache' to remove all items from the
70     ;; cache. There are a number of `file-cache-delete' functions provided
71     ;; as well, but in general it is probably better to not worry too much
72     ;; about extra files in the cache.
73     ;;
74     ;; The most convenient way to initialize the cache is with an
75 rms 1.5 ;; `eval-after-load' function, as noted in the ADDING FILES
76     ;; AUTOMATICALLY section.
77 rms 1.1 ;;
78     ;; FINDING FILES USING THE CACHE:
79     ;;
80     ;; You can use the file-cache with any function that expects a filename as
81     ;; an argument. For example:
82     ;;
83     ;; 1) Invoke a function which expects a filename as an argument:
84     ;; M-x find-file
85     ;;
86     ;; 2) Begin typing a file name.
87     ;;
88     ;; 3) Invoke `file-cache-minibuffer-complete' (bound by default to
89     ;; C-TAB) to complete on the filename using the cache.
90     ;;
91     ;; 4) When you have found a unique completion, the minibuffer contents
92     ;; will change to the full name of that file.
93 pbreton 1.9 ;;
94 rms 1.1 ;; If there are a number of directories which contain the completion,
95     ;; invoking `file-cache-minibuffer-complete' repeatedly will cycle through
96     ;; them.
97     ;;
98     ;; 5) You can then edit the minibuffer contents, or press RETURN.
99     ;;
100     ;; It is much easier to simply try it than trying to explain it :)
101     ;;
102 rms 1.5 ;;; ADDING FILES AUTOMATICALLY
103 rms 1.1 ;;
104     ;; For maximum utility, you should probably define an `eval-after-load'
105     ;; form which loads your favorite files:
106     ;;
107 pbreton 1.9 ;; (eval-after-load
108 rms 1.1 ;; "filecache"
109     ;; '(progn
110     ;; (message "Loading file cache...")
111     ;; (file-cache-add-directory-using-find "~/projects")
112     ;; (file-cache-add-directory-list load-path)
113     ;; (file-cache-add-directory "~/")
114     ;; (file-cache-add-file-list (list "~/foo/bar" "~/baz/bar"))
115     ;; ))
116     ;;
117     ;; If you clear and reload the cache frequently, it is probably easiest
118     ;; to put your initializations in a function:
119     ;;
120 pbreton 1.9 ;; (eval-after-load
121 rms 1.1 ;; "filecache"
122     ;; '(my-file-cache-initialize))
123 pbreton 1.9 ;;
124 rms 1.1 ;; (defun my-file-cache-initialize ()
125     ;; (interactive)
126     ;; (message "Loading file cache...")
127     ;; (file-cache-add-directory-using-find "~/projects")
128     ;; (file-cache-add-directory-list load-path)
129     ;; (file-cache-add-directory "~/")
130     ;; (file-cache-add-file-list (list "~/foo/bar" "~/baz/bar"))
131     ;; ))
132     ;;
133     ;; Of course, you can still add files to the cache afterwards, via
134     ;; Lisp functions.
135     ;;
136     ;; RELATED WORK:
137 pbreton 1.9 ;;
138 rms 1.1 ;; This package is a distant relative of Noah Friedman's fff utilities.
139     ;; Our goal is pretty similar, but the implementation strategies are
140     ;; different.
141 rms 1.2
142 rms 1.1 ;;; Code:
143    
144 pbreton 1.16 (eval-when-compile
145     (require 'find-lisp))
146    
147 schwab 1.3 (defgroup file-cache nil
148     "Find files using a pre-loaded cache."
149     :group 'files
150 done 1.6 :group 'convenience
151 schwab 1.3 :prefix "file-cache-")
152    
153 rms 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
154 rms 1.5 ;; Customization Variables
155 rms 1.1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
156    
157     ;; User-modifiable variables
158 pbreton 1.9 (defcustom file-cache-filter-regexps
159     (list "~$" "\\.o$" "\\.exe$" "\\.a$" "\\.elc$" ",v$" "\\.output$"
160 rms 1.7 "\\.$" "#$" "\\.class$")
161 rms 1.1 "*List of regular expressions used as filters by the file cache.
162     File names which match these expressions will not be added to the cache.
163 pbreton 1.9 Note that the functions `file-cache-add-file' and `file-cache-add-file-list'
164 schwab 1.3 do not use this variable."
165     :type '(repeat regexp)
166     :group 'file-cache)
167    
168     (defcustom file-cache-find-command "find"
169     "*External program used by `file-cache-add-directory-using-find'."
170     :type 'string
171     :group 'file-cache)
172    
173 uid65566 1.19 (defcustom file-cache-find-command-posix-flag 'not-defined
174     "*Set to t, if `file-cache-find-command' handles wildcards POSIX style.
175     This variable is automatically set to nil or non-nil
176     if it has the initial value `not-defined' whenever you first
177     call the `file-cache-add-directory-using-find'.
178    
179     Under Windows operating system where Cygwin is available, this value
180     should be t."
181     :type '(choice (const :tag "Yes" t)
182     (const :tag "No" nil)
183     (const :tag "Unknown" not-defined))
184     :group 'file-cache)
185    
186 schwab 1.3 (defcustom file-cache-locate-command "locate"
187     "*External program used by `file-cache-add-directory-using-locate'."
188     :type 'string
189     :group 'file-cache)
190 rms 1.1
191     ;; Minibuffer messages
192 schwab 1.3 (defcustom file-cache-no-match-message " [File Cache: No match]"
193     "Message to display when there is no completion."
194     :type 'string
195     :group 'file-cache)
196    
197     (defcustom file-cache-sole-match-message " [File Cache: sole completion]"
198     "Message to display when there is only one completion."
199     :type 'string
200     :group 'file-cache)
201    
202     (defcustom file-cache-non-unique-message
203     " [File Cache: complete but not unique]"
204     "Message to display when there is a non-unique completion."
205     :type 'string
206     :group 'file-cache)
207 rms 1.1
208 pbreton 1.9 (defcustom file-cache-completion-ignore-case
209 lektu 1.15 (if (memq system-type (list 'ms-dos 'windows-nt 'cygwin))
210 pbreton 1.9 t
211     completion-ignore-case)
212 gerd 1.8 "If non-nil, file-cache completion should ignore case.
213     Defaults to the value of `completion-ignore-case'."
214     :type 'sexp
215     :group 'file-cache
216     )
217    
218 pbreton 1.9 (defcustom file-cache-case-fold-search
219 lektu 1.15 (if (memq system-type (list 'ms-dos 'windows-nt 'cygwin))
220 pbreton 1.9 t
221     case-fold-search)
222     "If non-nil, file-cache completion should ignore case.
223     Defaults to the value of `case-fold-search'."
224     :type 'sexp
225     :group 'file-cache
226     )
227    
228 uid65566 1.18 (defcustom file-cache-ignore-case
229     (memq system-type (list 'ms-dos 'windows-nt 'cygwin))
230     "Non-nil means ignore case when checking completions in the file cache.
231     Defaults to nil on DOS and Windows, and t on other systems."
232 pbreton 1.9 :type 'sexp
233     :group 'file-cache
234     )
235    
236 rms 1.1 (defvar file-cache-multiple-directory-message nil)
237    
238     ;; Internal variables
239     ;; This should be named *Completions* because that's what the function
240     ;; switch-to-completions in simple.el expects
241 schwab 1.3 (defcustom file-cache-completions-buffer "*Completions*"
242     "Buffer to display completions when using the file cache."
243     :type 'string
244     :group 'file-cache)
245    
246 pbreton 1.9 (defcustom file-cache-buffer "*File Cache*"
247 schwab 1.3 "Buffer to hold the cache of file names."
248     :type 'string
249     :group 'file-cache)
250    
251     (defcustom file-cache-buffer-default-regexp "^.+$"
252     "Regexp to match files in `file-cache-buffer'."
253     :type 'regexp
254     :group 'file-cache)
255 rms 1.1
256     (defvar file-cache-last-completion nil)
257    
258     (defvar file-cache-alist nil
259     "Internal data structure to hold cache of file names.")
260    
261     (defvar file-cache-completions-keymap nil
262     "Keymap for file cache completions buffer.")
263    
264     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
265     ;; Functions to add files to the cache
266     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
267    
268     (defun file-cache-add-directory (directory &optional regexp)
269     "Add DIRECTORY to the file cache.
270 pbreton 1.9 If the optional REGEXP argument is non-nil, only files which match it will
271 rms 1.1 be added to the cache."
272 rms 1.5 (interactive "DAdd files from directory: ")
273     ;; Not an error, because otherwise we can't use load-paths that
274     ;; contain non-existent directories.
275     (if (not (file-accessible-directory-p directory))
276     (message "Directory %s does not exist" directory)
277     (let* ((dir (expand-file-name directory))
278     (dir-files (directory-files dir t regexp))
279     )
280     ;; Filter out files we don't want to see
281     (mapcar
282     '(lambda (file)
283 uid65566 1.19 (if (file-directory-p file)
284     (setq dir-files (delq file dir-files))
285     (mapcar
286     '(lambda (regexp)
287     (if (string-match regexp file)
288     (setq dir-files (delq file dir-files))))
289     file-cache-filter-regexps)))
290 rms 1.5 dir-files)
291     (file-cache-add-file-list dir-files))))
292 rms 1.1
293     (defun file-cache-add-directory-list (directory-list &optional regexp)
294     "Add DIRECTORY-LIST (a list of directory names) to the file cache.
295 pbreton 1.9 If the optional REGEXP argument is non-nil, only files which match it
296     will be added to the cache. Note that the REGEXP is applied to the files
297 rms 1.1 in each directory, not to the directory list itself."
298     (interactive "XAdd files from directory list: ")
299 pbreton 1.9 (mapcar
300 rms 1.1 '(lambda (dir) (file-cache-add-directory dir regexp))
301     directory-list))
302    
303     (defun file-cache-add-file-list (file-list)
304     "Add FILE-LIST (a list of files names) to the file cache."
305     (interactive "XFile List: ")
306     (mapcar 'file-cache-add-file file-list))
307    
308     ;; Workhorse function
309     (defun file-cache-add-file (file)
310     "Add FILE to the file cache."
311     (interactive "fAdd File: ")
312 rms 1.5 (if (not (file-exists-p file))
313 uid65627 1.21 (message "Filecache: file %s does not exist" file)
314 rms 1.5 (let* ((file-name (file-name-nondirectory file))
315     (dir-name (file-name-directory file))
316 uid65566 1.18 (the-entry (assoc-string
317     file-name file-cache-alist
318     file-cache-ignore-case))
319 rms 1.5 )
320     ;; Does the entry exist already?
321     (if the-entry
322     (if (or (and (stringp (cdr the-entry))
323     (string= dir-name (cdr the-entry)))
324     (and (listp (cdr the-entry))
325     (member dir-name (cdr the-entry))))
326     nil
327     (setcdr the-entry (append (list dir-name) (cdr the-entry)))
328     )
329     ;; If not, add it to the cache
330     (setq file-cache-alist
331 pbreton 1.9 (cons (cons file-name (list dir-name))
332 rms 1.5 file-cache-alist)))
333     )))
334 pbreton 1.9
335 rms 1.1 (defun file-cache-add-directory-using-find (directory)
336     "Use the `find' command to add files to the file cache.
337     Find is run in DIRECTORY."
338     (interactive "DAdd files under directory: ")
339     (let ((dir (expand-file-name directory)))
340 uid65566 1.19 (if (eq file-cache-find-command-posix-flag 'not-defined)
341 uid65566 1.20 (setq file-cache-find-command-posix-flag
342     (executable-command-find-posix-p file-cache-find-command)))
343 rms 1.1 (set-buffer (get-buffer-create file-cache-buffer))
344     (erase-buffer)
345 pbreton 1.9 (call-process file-cache-find-command nil
346 rms 1.1 (get-buffer file-cache-buffer) nil
347 pbreton 1.9 dir "-name"
348 uid65566 1.19 (cond
349     (file-cache-find-command-posix-flag
350     "\\*")
351     ((eq system-type 'windows-nt)
352     "'*'")
353     (t
354     "*"))
355 rms 1.1 "-print")
356     (file-cache-add-from-file-cache-buffer)))
357    
358     (defun file-cache-add-directory-using-locate (string)
359     "Use the `locate' command to add files to the file cache.
360     STRING is passed as an argument to the locate command."
361     (interactive "sAdd files using locate string: ")
362     (set-buffer (get-buffer-create file-cache-buffer))
363     (erase-buffer)
364 pbreton 1.9 (call-process file-cache-locate-command nil
365 rms 1.1 (get-buffer file-cache-buffer) nil
366     string)
367     (file-cache-add-from-file-cache-buffer))
368    
369 pbreton 1.16 (defun file-cache-add-directory-recursively (dir &optional regexp)
370     "Adds DIR and any subdirectories to the file-cache.
371     This function does not use any external programs
372     If the optional REGEXP argument is non-nil, only files which match it
373     will be added to the cache. Note that the REGEXP is applied to the files
374     in each directory, not to the directory list itself."
375     (interactive "DAdd directory: ")
376     (require 'find-lisp)
377     (mapcar
378     (function
379     (lambda(file)
380     (or (file-directory-p file)
381     (let (filtered)
382     (mapcar
383     (function
384     (lambda(regexp)
385     (and (string-match regexp file)
386     (setq filtered t))
387     ))
388     file-cache-filter-regexps)
389     filtered)
390     (file-cache-add-file file))))
391     (find-lisp-find-files dir (if regexp regexp "^"))))
392    
393 rms 1.1 (defun file-cache-add-from-file-cache-buffer (&optional regexp)
394     "Add any entries found in the file cache buffer.
395     Each entry matches the regular expression `file-cache-buffer-default-regexp'
396     or the optional REGEXP argument."
397     (set-buffer file-cache-buffer)
398 pbreton 1.9 (mapcar
399 rms 1.1 (function (lambda (elt)
400     (goto-char (point-min))
401     (delete-matching-lines elt)))
402     file-cache-filter-regexps)
403     (goto-char (point-min))
404     (let ((full-filename))
405     (while (re-search-forward
406 pbreton 1.9 (or regexp file-cache-buffer-default-regexp)
407 rms 1.1 (point-max) t)
408     (setq full-filename (buffer-substring-no-properties
409 pbreton 1.9 (match-beginning 0) (match-end 0)))
410 rms 1.1 (file-cache-add-file full-filename))))
411    
412     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
413     ;; Functions to delete from the cache
414     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
415    
416     (defun file-cache-clear-cache ()
417     "Clear the file cache."
418     (interactive)
419     (setq file-cache-alist nil))
420    
421     ;; This clears *all* files with the given name
422     (defun file-cache-delete-file (file)
423     "Delete FILE from the file cache."
424     (interactive
425     (list (completing-read "Delete file from cache: " file-cache-alist)))
426 pbreton 1.9 (setq file-cache-alist
427 uid65566 1.18 (delq (assoc-string file file-cache-alist file-cache-ignore-case)
428 pbreton 1.9 file-cache-alist)))
429 rms 1.1
430     (defun file-cache-delete-file-list (file-list)
431     "Delete FILE-LIST (a list of files) from the file cache."
432     (interactive "XFile List: ")
433     (mapcar 'file-cache-delete-file file-list))
434    
435     (defun file-cache-delete-file-regexp (regexp)
436     "Delete files matching REGEXP from the file cache."
437     (interactive "sRegexp: ")
438     (let ((delete-list))
439 pbreton 1.9 (mapcar '(lambda (elt)
440 rms 1.1 (and (string-match regexp (car elt))
441     (setq delete-list (cons (car elt) delete-list))))
442     file-cache-alist)
443     (file-cache-delete-file-list delete-list)
444 uid65627 1.21 (message "Filecache: deleted %d files from file cache"
445     (length delete-list))))
446 rms 1.1
447     (defun file-cache-delete-directory (directory)
448     "Delete DIRECTORY from the file cache."
449     (interactive "DDelete directory from file cache: ")
450     (let ((dir (expand-file-name directory))
451     (result 0))
452 pbreton 1.9 (mapcar
453     '(lambda (entry)
454 rms 1.1 (if (file-cache-do-delete-directory dir entry)
455     (setq result (1+ result))))
456     file-cache-alist)
457     (if (zerop result)
458 uid65627 1.21 (error "Filecache: no entries containing %s found in cache" directory)
459     (message "Filecache: deleted %d entries" result))))
460 rms 1.1
461     (defun file-cache-do-delete-directory (dir entry)
462     (let ((directory-list (cdr entry))
463     (directory (file-cache-canonical-directory dir))
464     )
465     (and (member directory directory-list)
466     (if (equal 1 (length directory-list))
467 pbreton 1.9 (setq file-cache-alist
468 rms 1.1 (delq entry file-cache-alist))
469     (setcdr entry (delete directory directory-list)))
470     )
471     ))
472    
473     (defun file-cache-delete-directory-list (directory-list)
474     "Delete DIRECTORY-LIST (a list of directories) from the file cache."
475     (interactive "XDirectory List: ")
476     (mapcar 'file-cache-delete-directory directory-list))
477    
478     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
479     ;; Utility functions
480     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
481    
482     ;; Returns the name of a directory for a file in the cache
483     (defun file-cache-directory-name (file)
484 uid65566 1.18 (let* ((directory-list (cdr (assoc-string
485     file file-cache-alist
486     file-cache-ignore-case)))
487 rms 1.1 (len (length directory-list))
488     (directory)
489     (num)
490     )
491     (if (not (listp directory-list))
492 uid65627 1.21 (error "Filecache: unknown type in file-cache-alist for key %s" file))
493 pbreton 1.9 (cond
494 rms 1.1 ;; Single element
495     ((eq 1 len)
496     (setq directory (elt directory-list 0)))
497     ;; No elements
498     ((eq 0 len)
499 uid65627 1.21 (error "Filecache: no directory found for key %s" file))
500 rms 1.1 ;; Multiple elements
501     (t
502 miles 1.12 (let* ((minibuffer-dir (file-name-directory (minibuffer-contents)))
503 rms 1.1 (dir-list (member minibuffer-dir directory-list))
504     )
505     (setq directory
506     ;; If the directory is in the list, return the next element
507     ;; Otherwise, return the first element
508 pbreton 1.9 (if dir-list
509     (or (elt directory-list
510 rms 1.1 (setq num (1+ (- len (length dir-list)))))
511     (elt directory-list (setq num 0)))
512     (elt directory-list (setq num 0))))
513     )
514     )
515     )
516     ;; If there were multiple directories, set up a minibuffer message
517     (setq file-cache-multiple-directory-message
518     (and num (format " [%d of %d]" (1+ num) len)))
519     directory))
520    
521     ;; Returns the name of a file in the cache
522     (defun file-cache-file-name (file)
523     (let ((directory (file-cache-directory-name file)))
524     (concat directory file)))
525 pbreton 1.9
526 rms 1.1 ;; Return a canonical directory for comparison purposes.
527     ;; Such a directory ends with a forward slash.
528     (defun file-cache-canonical-directory (dir)
529     (let ((directory dir))
530     (if (not (char-equal ?/ (string-to-char (substring directory -1))))
531     (concat directory "/")
532     directory)))
533    
534     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
535     ;; Minibuffer functions
536     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
537    
538 rms 1.2 ;; The prefix argument works around a bug in the minibuffer completion.
539     ;; The completion function doesn't distinguish between the states:
540 pbreton 1.9 ;;
541 rms 1.2 ;; "Multiple completions of name" (eg, Makefile, Makefile.in)
542     ;; "Name available in multiple directories" (/tmp/Makefile, ~me/Makefile)
543 pbreton 1.9 ;;
544 rms 1.2 ;; The default is to do the former; a prefix arg forces the latter.
545    
546 rms 1.1 ;;;###autoload
547 rms 1.2 (defun file-cache-minibuffer-complete (arg)
548     "Complete a filename in the minibuffer using a preloaded cache.
549     Filecache does two kinds of substitution: it completes on names in
550     the cache, and, once it has found a unique name, it cycles through
551 pbreton 1.9 the directories that the name is available in. With a prefix argument,
552     the name is considered already unique; only the second substitution
553 rms 1.2 \(directories) is done."
554 pbreton 1.9 (interactive "P")
555     (let*
556 rms 1.1 (
557 gerd 1.8 (completion-ignore-case file-cache-completion-ignore-case)
558 pbreton 1.9 (case-fold-search file-cache-case-fold-search)
559 miles 1.12 (string (file-name-nondirectory (minibuffer-contents)))
560 rms 1.2 (completion-string (try-completion string file-cache-alist))
561 rms 1.1 (completion-list)
562     (len)
563     (file-cache-string)
564     )
565 pbreton 1.9 (cond
566 rms 1.2 ;; If it's the only match, replace the original contents
567     ((or arg (eq completion-string t))
568     (setq file-cache-string (file-cache-file-name string))
569 miles 1.12 (if (string= file-cache-string (minibuffer-contents))
570 rms 1.2 (file-cache-temp-minibuffer-message file-cache-sole-match-message)
571 miles 1.12 (delete-minibuffer-contents)
572 pj 1.13 (insert file-cache-string)
573 rms 1.2 (if file-cache-multiple-directory-message
574 pbreton 1.9 (file-cache-temp-minibuffer-message
575 rms 1.2 file-cache-multiple-directory-message))
576     ))
577    
578 rms 1.1 ;; If it's the longest match, insert it
579     ((stringp completion-string)
580     ;; If we've already inserted a unique string, see if the user
581     ;; wants to use that one
582     (if (and (string= string completion-string)
583 uid65566 1.18 (assoc-string string file-cache-alist
584     file-cache-ignore-case))
585 rms 1.1 (if (and (eq last-command this-command)
586     (string= file-cache-last-completion completion-string))
587 pbreton 1.9 (progn
588 miles 1.12 (delete-minibuffer-contents)
589 pj 1.13 (insert (file-cache-file-name completion-string))
590 rms 1.1 (setq file-cache-last-completion nil)
591     )
592     (file-cache-temp-minibuffer-message file-cache-non-unique-message)
593     (setq file-cache-last-completion string)
594     )
595     (setq file-cache-last-completion string)
596     (setq completion-list (all-completions string file-cache-alist)
597     len (length completion-list))
598     (if (> len 1)
599     (progn
600     (goto-char (point-max))
601 pj 1.13 (insert
602 rms 1.1 (substring completion-string (length string)))
603     ;; Add our own setup function to the Completions Buffer
604     (let ((completion-setup-hook
605 pbreton 1.9 (reverse
606 rms 1.1 (append (list 'file-cache-completion-setup-function)
607     completion-setup-hook)))
608     )
609     (with-output-to-temp-buffer file-cache-completions-buffer
610     (display-completion-list completion-list))
611     )
612     )
613     (setq file-cache-string (file-cache-file-name completion-string))
614 miles 1.12 (if (string= file-cache-string (minibuffer-contents))
615 pbreton 1.9 (file-cache-temp-minibuffer-message
616 rms 1.2 file-cache-sole-match-message)
617 miles 1.12 (delete-minibuffer-contents)
618 pj 1.13 (insert file-cache-string)
619 rms 1.1 (if file-cache-multiple-directory-message
620 pbreton 1.9 (file-cache-temp-minibuffer-message
621 rms 1.1 file-cache-multiple-directory-message)))
622     )))
623 pbreton 1.9
624 rms 1.1 ;; No match
625     ((eq completion-string nil)
626     (file-cache-temp-minibuffer-message file-cache-no-match-message))
627     )
628     ))
629    
630     ;; Lifted from "complete.el"
631     (defun file-cache-temp-minibuffer-message (msg)
632     "A Lisp version of `temp_minibuffer_message' from minibuf.c."
633     (let ((savemax (point-max)))
634     (save-excursion
635     (goto-char (point-max))
636     (insert msg))
637     (let ((inhibit-quit t))
638     (sit-for 2)
639     (delete-region savemax (point-max))
640     (if quit-flag
641     (setq quit-flag nil
642     unread-command-events (list 7))))))
643    
644     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
645     ;; Completion functions
646     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
647    
648     (defun file-cache-completion-setup-function ()
649     (set-buffer file-cache-completions-buffer)
650    
651     (if file-cache-completions-keymap
652     nil
653 pbreton 1.9 (setq file-cache-completions-keymap
654 rms 1.1 (copy-keymap completion-list-mode-map))
655 pbreton 1.9 (define-key file-cache-completions-keymap [mouse-2]
656     'file-cache-mouse-choose-completion)
657     (define-key file-cache-completions-keymap "\C-m"
658 rms 1.1 'file-cache-choose-completion))
659    
660     (use-local-map file-cache-completions-keymap)
661     )
662    
663     (defun file-cache-choose-completion ()
664     "Choose a completion in the `*Completions*' buffer."
665     (interactive)
666     (let ((completion-no-auto-exit t))
667     (choose-completion)
668     (select-window (active-minibuffer-window))
669 rms 1.2 (file-cache-minibuffer-complete nil)
670 rms 1.1 )
671     )
672    
673     (defun file-cache-mouse-choose-completion (event)
674     "Choose a completion with the mouse."
675     (interactive "e")
676     (let ((completion-no-auto-exit t))
677     (mouse-choose-completion event)
678     (select-window (active-minibuffer-window))
679 rms 1.2 (file-cache-minibuffer-complete nil)
680 rms 1.1 )
681     )
682 gerd 1.8
683 pbreton 1.16 (defun file-cache-complete ()
684     "Complete the word at point, using the filecache."
685     (interactive)
686     (let (start pattern completion all)
687     (save-excursion
688     (skip-syntax-backward "^\"")
689     (setq start (point)))
690     (setq pattern (buffer-substring-no-properties start (point)))
691     (setq completion (try-completion pattern file-cache-alist))
692     (setq all (all-completions pattern file-cache-alist nil))
693     (cond ((eq completion t))
694     ((null completion)
695     (message "Can't find completion for \"%s\"" pattern)
696     (ding))
697     ((not (string= pattern completion))
698     (delete-region start (point))
699     (insert completion)
700     )
701     (t
702     (with-output-to-temp-buffer "*Completions*"
703     (display-completion-list all))
704     ))
705     ))
706    
707 gerd 1.8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
708     ;; Show parts of the cache
709     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
710    
711     (defun file-cache-files-matching-internal (regexp)
712     "Output a list of files whose names (not including directories)
713     match REGEXP."
714     (let ((results))
715     (mapcar
716     (function
717     (lambda(cache-element)
718     (and (string-match regexp
719     (elt cache-element 0))
720     (if results
721     (nconc results (list (elt cache-element 0)))
722     (setq results (list (elt cache-element 0)))))))
723     file-cache-alist)
724     results))
725    
726     (defun file-cache-files-matching (regexp)
727     "Output a list of files whose names (not including directories)
728     match REGEXP."
729     (interactive "sFind files matching regexp: ")
730 pbreton 1.9 (let ((results
731 gerd 1.8 (file-cache-files-matching-internal regexp))
732     buf)
733 pbreton 1.9 (set-buffer
734     (setq buf (get-buffer-create
735 gerd 1.8 "*File Cache Files Matching*")))
736     (erase-buffer)
737     (insert
738     (mapconcat
739     'identity
740     results
741     "\n"))
742     (goto-char (point-min))
743     (display-buffer buf)))
744 rms 1.1
745     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
746     ;; Debugging functions
747     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
748    
749     (defun file-cache-debug-read-from-minibuffer (file)
750     "Debugging function."
751 pbreton 1.9 (interactive
752 rms 1.1 (list (completing-read "File Cache: " file-cache-alist)))
753 uid65566 1.18 (message "%s" (assoc-string file file-cache-alist
754     file-cache-ignore-case))
755 rms 1.1 )
756 pbreton 1.16
757     (defun file-cache-display ()
758     "Display the file cache."
759     (interactive)
760     (let ((buf "*File Cache Contents*"))
761     (with-current-buffer
762     (get-buffer-create buf)
763     (erase-buffer)
764     (mapcar
765     (function
766     (lambda(item)
767     (insert (nth 1 item) (nth 0 item) "\n")))
768     file-cache-alist)
769     (pop-to-buffer buf)
770     )))
771 rms 1.1
772     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
773     ;; Keybindings
774     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
775    
776     ;;;###autoload (define-key minibuffer-local-completion-map [C-tab] 'file-cache-minibuffer-complete)
777     ;;;###autoload (define-key minibuffer-local-map [C-tab] 'file-cache-minibuffer-complete)
778     ;;;###autoload (define-key minibuffer-local-must-match-map [C-tab] 'file-cache-minibuffer-complete)
779    
780     (provide 'filecache)
781    
782 miles 1.17 ;;; arch-tag: 433d3ca4-4af2-47ce-b2cf-1f727460f538
783 rms 1.1 ;;; filecache.el ends here

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26