Mercurial > hg > xemacs-beta

comparison lisp/utils/lib-complete.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 0293115a14e9
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;; ========================================================================
2 ;; lib-complete.el -- Completion on a search path
3 ;; Author : Mike Williams <mike-w@cs.aukuni.ac.nz>
4 ;; Created On : Sat Apr 20 17:47:21 1991
5 ;; Last Modified By: Heiko M|nkel <muenkel@tnt.uni-hannover.de>
6 ;; Additional XEmacs integration By: Chuck Thompson <cthomp@cs.uiuc.edu>
7 ;; Last Modified On: Thu Jul 1 14:23:00 1994
8 ;; RCS Info : $Revision: 1.1.1.1 $ $Locker: $
9 ;; ========================================================================
10 ;; NOTE: this file must be recompiled if changed.
11 ;;
12 ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
13 ;;
14 ;; Keywords: utility, lisp
15
16 ;; This file is part of XEmacs.
17
18 ;; XEmacs is free software; you can redistribute it and/or modify it
19 ;; under the terms of the GNU General Public License as published by
20 ;; the Free Software Foundation; either version 2, or (at your option)
21 ;; any later version.
22
23 ;; XEmacs is distributed in the hope that it will be useful, but
24 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
25 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
26 ;; General Public License for more details.
27
28 ;; You should have received a copy of the GNU General Public License
29 ;; along with XEmacs; see the file COPYING. If not, write to the Free
30 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
31
32 ;;; Synched up with: Not in FSF.
33
34 ;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his
35 ;; helpful suggestions.
36
37 ;; The function locate-file is removed, because of its incompatibility
38 ;; with the buildin function of the lemacs 19.10 (Heiko M|nkel).
39
40 ;; There is now the new function find-library in this package.
41
42 (provide 'lib-complete)
43
44 ;;=== Usage ===============================================================
45 ;;
46 ;; (autoload (fmakunbound 'load-library) "lib-complete" nil t)
47 ;; (autoload 'library-all-completions "lib-complete")
48 ;; (autoload 'read-library "lib-complete")
49 ;; (autoload 'find-library "lib-complete"
50 ;; "Find and edit the source for the library named LIBRARY.
51 ;; The extension of the LIBRARY must be omitted.")
52
53 ;;=== Locate a file in a search path ======================================
54
55 ;(defun locate-file (FILE SEARCH-PATH &optional SUFFIX-LIST PRED)
56 ; "Search for FILE on SEARCH-PATH (list). If optional SUFFIX-LIST is
57 ;provided, allow file to be followed by one of the suffixes.
58 ;Optional second argument PRED restricts the number of files which
59 ;may match. The default is file-exists-p."
60 ; (if (not SUFFIX-LIST) (setq SUFFIX-LIST '("")))
61 ; (if (not PRED) (setq PRED 'file-exists-p))
62 ; (if (file-name-absolute-p FILE) (setq SEARCH-PATH '(nil)))
63 ; (if (equal FILE "") (error "Empty filename"))
64 ; (let ((filelist
65 ; (mapcar
66 ; (function (lambda (ext) (concat FILE ext)))
67 ; SUFFIX-LIST)))
68 ; ;; Search SEARCH-PATH for a readable file in filelist
69 ; (catch 'found
70 ; (while SEARCH-PATH
71 ; (let ((filelist filelist))
72 ; (while filelist
73 ; (let ((filepath (expand-file-name (car filelist)
74 ; (car SEARCH-PATH))))
75 ; (if (funcall PRED filepath)
76 ; (throw 'found filepath)))
77 ; (setq filelist (cdr filelist))))
78 ; (setq SEARCH-PATH (cdr SEARCH-PATH))))
79 ; ))
80
81 ;;=== Determine completions for filename in search path ===================
82
83 (defun library-all-completions (FILE SEARCH-PATH &optional FULL FAST)
84 "Return all completions for FILE in any directory on SEARCH-PATH.
85 If optional third argument FULL is non-nil, returned pathnames should be
86 absolute rather than relative to some directory on the SEARCH-PATH.
87 If optional fourth argument FAST is non-nil, don't sort the completions,
88 or remove duplicates."
89 (setq FILE (or FILE ""))
90 (if (file-name-absolute-p FILE)
91 ;; It's an absolute file name, so don't need SEARCH-PATH
92 (progn
93 (setq FILE (expand-file-name FILE))
94 (file-name-all-completions
95 (file-name-nondirectory FILE) (file-name-directory FILE)))
96 (let ((subdir (file-name-directory FILE))
97 (file (file-name-nondirectory FILE))
98 all-completions)
99 ;; Make list of completions in each directory on SEARCH-PATH
100 (while SEARCH-PATH
101 (let* ((dir (concat (file-name-as-directory
102 (expand-file-name (car SEARCH-PATH)))
103 subdir))
104 (dir-prefix (if FULL dir subdir)))
105 (if (file-directory-p dir)
106 (let ((subdir-completions
107 (file-name-all-completions file dir)))
108 (while subdir-completions
109 (setq all-completions
110 (cons (concat dir-prefix (car subdir-completions))
111 all-completions))
112 (setq subdir-completions (cdr subdir-completions))))))
113 (setq SEARCH-PATH (cdr SEARCH-PATH)))
114 (if FAST all-completions
115 (let ((sorted (nreverse (sort all-completions 'string<)))
116 compressed)
117 (while sorted
118 (if (equal (car sorted) (car compressed)) nil
119 (setq compressed (cons (car sorted) compressed)))
120 (setq sorted (cdr sorted)))
121 compressed)))))
122
123 ;;=== Utilities ===========================================================
124
125 (defmacro progn-with-message (MESSAGE &rest FORMS)
126 "(progn-with-message MESSAGE FORMS ...)
127 Display MESSAGE and evaluate FORMS, returning value of the last one."
128 ;; based on Hallvard Furuseth's funcall-with-message
129 (`
130 (if (eq (selected-window) (minibuffer-window))
131 (save-excursion
132 (goto-char (point-max))
133 (let ((orig-pmax (point-max)))
134 (unwind-protect
135 (progn
136 (insert " " (, MESSAGE)) (goto-char orig-pmax)
137 (sit-for 0) ; Redisplay
138 (,@ FORMS))
139 (delete-region orig-pmax (point-max)))))
140 (prog2
141 (message "%s" (, MESSAGE))
142 (progn (,@ FORMS))
143 (message "")))))
144
145 (put 'progn-with-message 'lisp-indent-hook 1)
146
147 ;;=== Completion caching ==================================================
148
149 (defconst lib-complete:cache nil
150 "Used within read-library and read-library-internal to prevent
151 costly repeated calls to library-all-completions.
152 Format is a list of lists of the form
153
154 ([<path> <subdir>] <cache-record> <cache-record> ...)
155
156 where each <cache-record> has the form
157
158 (<root> <modtimes> <completion-table>)")
159
160 (defun lib-complete:better-root (ROOT1 ROOT2)
161 "Return non-nil if ROOT1 is a superset of ROOT2."
162 (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
163 (string-match
164 (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
165 ROOT2)))
166
167 (defun lib-complete:get-completion-table (FILE PATH FILTER)
168 (let* ((subdir (file-name-directory FILE))
169 (root (file-name-nondirectory FILE))
170 (PATH
171 (mapcar
172 (function (lambda (dir) (file-name-as-directory
173 (expand-file-name (or dir "")))))
174 PATH))
175 (key (vector PATH subdir FILTER))
176 (real-dirs
177 (if subdir
178 (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
179 PATH))
180 (path-modtimes
181 (mapcar
182 (function (lambda (fn) (if fn (nth 5 (file-attributes fn)))))
183 real-dirs))
184 (cache-entry (assoc key lib-complete:cache))
185 (cache-records (cdr cache-entry)))
186 ;; Look for cached entry
187 (catch 'table
188 (while cache-records
189 (if (and
190 (lib-complete:better-root (nth 0 (car cache-records)) root)
191 (equal (nth 1 (car cache-records)) path-modtimes))
192 (throw 'table (nth 2 (car cache-records))))
193 (setq cache-records (cdr cache-records)))
194 ;; Otherwise build completions
195 (let ((completion-list
196 (progn-with-message "(building completion table...)"
197 (library-all-completions FILE PATH nil 'fast)))
198 (completion-table (make-vector 127 0)))
199 (while completion-list
200 (let ((completion
201 (if (or (not FILTER)
202 (file-directory-p (car completion-list)))
203 (car completion-list)
204 (funcall FILTER (car completion-list)))))
205 (if completion
206 (intern completion completion-table)))
207 (setq completion-list (cdr completion-list)))
208 ;; Cache the completions
209 (lib-complete:cache-completions key root
210 path-modtimes completion-table)
211 completion-table))))
212
213 (defvar lib-complete:max-cache-size 20
214 "*Maximum number of search paths which are cached.")
215
216 (defun lib-complete:cache-completions (key root modtimes table)
217 (let* ((cache-entry (assoc key lib-complete:cache))
218 (cache-records (cdr cache-entry))
219 (new-cache-records (list (list root modtimes table))))
220 (if (not cache-entry) nil
221 ;; Remove old cache entry
222 (setq lib-complete:cache (delq cache-entry lib-complete:cache))
223 ;; Copy non-redundant entries from old cache entry
224 (while cache-records
225 (if (or (equal root (nth 0 (car cache-records)))
226 (lib-complete:better-root root (nth 0 (car cache-records))))
227 nil
228 (setq new-cache-records
229 (cons (car cache-records) new-cache-records)))
230 (setq cache-records (cdr cache-records))))
231 ;; Add entry to front of cache
232 (setq lib-complete:cache
233 (cons (cons key (nreverse new-cache-records)) lib-complete:cache))
234 ;; Trim cache
235 (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
236 (if tail (setcdr tail nil)))))
237
238 ;;=== Read a filename, with completion in a search path ===================
239
240 (defun read-library-internal (FILE FILTER FLAG)
241 "Don't call this."
242 ;; Relies on read-library-internal-search-path being let-bound
243 (let ((completion-table
244 (lib-complete:get-completion-table
245 FILE read-library-internal-search-path FILTER)))
246 (cond
247 ((not completion-table) nil)
248 ;; Completion table is filtered before use, so the PREDICATE
249 ;; argument is redundant.
250 ((eq FLAG nil) (try-completion FILE completion-table nil))
251 ((eq FLAG t) (all-completions FILE completion-table nil))
252 ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
253 )))
254
255 (defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH
256 FULL FILTER)
257 "Read library name, prompting with PROMPT and completing in directories
258 from SEARCH-PATH. A nil in the search path represents the current
259 directory. Completions for a given search-path are cached, with the
260 cache being invalidated whenever one of the directories on the path changes.
261 Default to DEFAULT if user enters a null string.
262 Optional fourth arg MUST-MATCH non-nil means require existing file's name.
263 Non-nil and non-t means also require confirmation after completion.
264 Optional fifth argument FULL non-nil causes a full pathname, rather than a
265 relative pathname, to be returned. Note that FULL implies MUST-MATCH.
266 Optional sixth argument FILTER can be used to provide a function to
267 filter the completions. This function is passed the filename, and should
268 return a transformed filename (possibly a null transformation) or nil,
269 indicating that the filename should not be included in the completions."
270 (let* ((read-library-internal-search-path SEARCH-PATH)
271 (library (completing-read PROMPT 'read-library-internal
272 FILTER (or MUST-MATCH FULL) nil)))
273 (cond
274 ((equal library "") DEFAULT)
275 (FULL (locate-file library read-library-internal-search-path ".el:.elc"))
276 (t library))))
277
278 ;; NOTE: as a special case, read-library may be used to read a filename
279 ;; relative to the current directory, returning a *relative* pathname
280 ;; (read-file-name returns a full pathname).
281 ;;
282 ;; eg. (read-library "Local header: " '(nil) nil)
283
284 (defun get-library-path ()
285 "Front end to read-library"
286 (read-library "Find Library file: " load-path nil t t
287 (function (lambda (fn)
288 (cond
289 ((string-match "\\.el$" fn)
290 (substring fn 0 (match-beginning 0))))))
291 ))
292
293 ;;=== Replacement for load-library with completion ========================
294
295 (defun load-library (library)
296 "Load the library named LIBRARY.
297 This is an interface to the function `load'."
298 (interactive
299 (list (read-library "Load Library: " load-path nil nil nil
300 (function (lambda (fn)
301 (cond
302 ((string-match "\\.elc?$" fn)
303 (substring fn 0 (match-beginning 0))))))
304 )))
305 (load library))
306
307 ;;=== find-library with completion (Author: Heiko Muenkel) ===================
308
309 (defun find-library (library)
310 "Find and edit the source for the library named LIBRARY.
311 The extension of the LIBRARY must be omitted."
312 (interactive
313 (list
314 (get-library-path)))
315 (find-file library))
316
317 (defun find-library-other-window (library)
318 "Load the library named LIBRARY in another window."
319 (interactive
320 (list (get-library-path)))
321 (find-file-other-window library))
322
323 (defun find-library-other-frame (library)
324 "Load the library named LIBRARY in a newly-created frame."
325 (interactive
326 (list (get-library-path)))
327 (find-file-other-frame library))
328
329 ; This conflicts with an existing binding
330 ;(define-key global-map "\C-xl" 'find-library)
331 (define-key global-map "\C-x4l" 'find-library-other-window)
332 (define-key global-map "\C-x5l" 'find-library-other-frame)