Mercurial > hg > xemacs-beta

comparison lisp/lib-complete.el @ 209:41ff10fd062f r20-4b3

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