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