1 ;;; lib-complete.el --- Completion on the lisp search path
3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
6 ;; Author: Mike Williams <mike-w@cs.aukuni.ac.nz>
7 ;; Maintainer: SXEmacs Development Team
8 ;; Keywords: lisp, extensions, dumped
9 ;; Created: Sat Apr 20 17:47:21 1991
11 ;; This file is part of SXEmacs.
13 ;; SXEmacs is free software: you can redistribute it and/or modify
14 ;; it under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation, either version 3 of the License, or
16 ;; (at your option) any later version.
18 ;; SXEmacs is distributed in the hope that it will be useful,
19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 ;; GNU General Public License for more details.
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.
26 ;;; Synched up with: Not in FSF.
30 ;; This file is dumped with SXEmacs.
32 ;; ========================================================================
33 ;; lib-complete.el -- Completion on a search path
34 ;; Author : Mike Williams <mike-w@cs.aukuni.ac.nz>
35 ;; Created On : Sat Apr 20 17:47:21 1991
36 ;; Last Modified By: Heiko M|nkel <muenkel@tnt.uni-hannover.de>
37 ;; Additional XEmacs integration By: Chuck Thompson <cthomp@cs.uiuc.edu>
38 ;; Last Modified On: Thu Jul 1 14:23:00 1994
39 ;; ========================================================================
40 ;; NOTE: XEmacs must be redumped if this file is changed.
42 ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
44 ;; Keywords: utility, lisp
46 ;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his
47 ;; helpful suggestions.
49 ;; The function locate-file is removed, because of its incompatibility
50 ;; with the buildin function of the lemacs 19.10 (Heiko M|nkel).
52 ;; There is now the new function find-library in this package.
56 ;; 4/26/97: sb Mule-ize.
57 ;; 6/24/1999 much rewriting from Bob Weiner
61 ;;=== Determine completions for filename in search path ===================
63 (defun library-all-completions (FILE SEARCH-PATH &optional FULL FAST)
64 "Return all completions for FILE in any directory on SEARCH-PATH.
65 If optional third argument FULL is non-nil, returned pathnames should be
66 absolute rather than relative to some directory on the SEARCH-PATH.
67 If optional fourth argument FAST is non-nil, don't sort the completions,
68 or remove duplicates."
69 (setq FILE (or FILE ""))
70 (if (file-name-absolute-p FILE)
71 ;; It's an absolute file name, so don't need SEARCH-PATH
73 (setq FILE (expand-file-name FILE))
74 (file-name-all-completions
75 (file-name-nondirectory FILE) (file-name-directory FILE)))
76 (let ((subdir (file-name-directory FILE))
77 (file (file-name-nondirectory FILE))
79 ;; Make list of completions in each directory on SEARCH-PATH
81 (let* ((dir (concat (file-name-as-directory
82 (expand-file-name (car SEARCH-PATH)))
84 (dir-prefix (if FULL dir subdir)))
85 (if (file-directory-p dir)
86 (let ((subdir-completions
87 (file-name-all-completions file dir)))
88 (while subdir-completions
90 (cons (concat dir-prefix (car subdir-completions))
92 (setq subdir-completions (cdr subdir-completions))))))
93 (setq SEARCH-PATH (cdr SEARCH-PATH)))
94 (if FAST all-completions
95 (let ((sorted (nreverse (sort all-completions 'string<)))
98 (if (equal (car sorted) (car compressed)) nil
99 (setq compressed (cons (car sorted) compressed)))
100 (setq sorted (cdr sorted)))
103 ;;=== Utilities ===========================================================
105 (defmacro progn-with-message (message &rest forms)
106 "(progn-with-message MESSAGE FORMS ...)
107 Display MESSAGE and evaluate FORMS, returning value of the last one."
108 ;; based on Hallvard Furuseth's funcall-with-message
109 `(if (eq (selected-window) (minibuffer-window))
111 (goto-char (point-max))
112 (let ((orig-pmax (point-max)))
115 (insert " " ,message) (goto-char orig-pmax)
116 (sit-for 0) ; Redisplay
118 (delete-region orig-pmax (point-max)))))
120 (message "%s" ,message)
124 (put 'progn-with-message 'lisp-indent-hook 1)
126 ;;=== Completion caching ==================================================
128 (defconst lib-complete:cache nil
129 "Used within `read-library' and `read-library-internal' to prevent
130 costly repeated calls to `library-all-completions'.
131 Format is a list of lists of the form
133 ([<path> <subdir>] <cache-record> <cache-record> ...)
135 where each <cache-record> has the form
137 (<root> <modtimes> <completion-table>)")
139 (defun lib-complete:better-root (ROOT1 ROOT2)
140 "Return non-nil if ROOT1 is a superset of ROOT2."
141 (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
143 (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
146 (defun lib-complete:get-completion-table (FILE PATH FILTER)
147 (let* ((subdir (file-name-directory FILE))
148 (root (file-name-nondirectory FILE))
151 (function (lambda (dir) (file-name-as-directory
152 (expand-file-name (or dir "")))))
154 (key (vector PATH subdir FILTER))
157 (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
161 (function (lambda (fn) (if fn (nth 5 (file-attributes fn)))))
163 (cache-entry (assoc key lib-complete:cache))
164 (cache-records (cdr cache-entry)))
165 ;; Look for cached entry
169 (lib-complete:better-root (nth 0 (car cache-records)) root)
170 (equal (nth 1 (car cache-records)) path-modtimes))
171 (throw 'table (nth 2 (car cache-records))))
172 (setq cache-records (cdr cache-records)))
173 ;; Otherwise build completions
174 (let ((completion-list
175 (progn-with-message "(building completion table...)"
176 (library-all-completions FILE PATH nil 'fast)))
177 (completion-table (make-vector 127 0)))
178 (while completion-list
181 (file-directory-p (car completion-list)))
182 (car completion-list)
183 (funcall FILTER (car completion-list)))))
185 (intern completion completion-table)))
186 (setq completion-list (cdr completion-list)))
187 ;; Cache the completions
188 (lib-complete:cache-completions key root
189 path-modtimes completion-table)
192 (defvar lib-complete:max-cache-size 40
193 "*Maximum number of search paths which are cached.")
195 (defun lib-complete:cache-completions (key root modtimes table)
196 (let* ((cache-entry (assoc key lib-complete:cache))
197 (cache-records (cdr cache-entry))
198 (new-cache-records (list (list root modtimes table))))
199 (if (not cache-entry) nil
200 ;; Remove old cache entry
201 (setq lib-complete:cache (delq cache-entry lib-complete:cache))
202 ;; Copy non-redundant entries from old cache entry
204 (if (or (equal root (nth 0 (car cache-records)))
205 (lib-complete:better-root root (nth 0 (car cache-records))))
207 (setq new-cache-records
208 (cons (car cache-records) new-cache-records)))
209 (setq cache-records (cdr cache-records))))
210 ;; Add entry to front of cache
211 (setq lib-complete:cache
212 (cons (cons key (nreverse new-cache-records)) lib-complete:cache))
214 (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
215 (if tail (setcdr tail nil)))))
217 ;;=== Read a filename, with completion in a search path ===================
219 (defun read-library-internal (FILE FILTER FLAG)
221 ;; Relies on read-library-internal-search-path being let-bound
222 (declare (special read-library-internal-search-path))
223 (let ((completion-table
224 (lib-complete:get-completion-table
225 FILE read-library-internal-search-path FILTER)))
227 ((not completion-table) nil)
228 ;; Completion table is filtered before use, so the PREDICATE
229 ;; argument is redundant.
230 ((eq FLAG nil) (try-completion FILE completion-table nil))
231 ((eq FLAG t) (all-completions FILE completion-table nil))
232 ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
235 (defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH
237 "Read library name, prompting with PROMPT and completing in directories
238 from SEARCH-PATH. A nil in the search path represents the current
239 directory. Completions for a given search-path are cached, with the
240 cache being invalidated whenever one of the directories on the path changes.
241 Default to DEFAULT if user enters a null string.
242 Optional fourth arg MUST-MATCH non-nil means require existing file's name.
243 Non-nil and non-t means also require confirmation after completion.
244 Optional fifth argument FULL non-nil causes a full pathname, rather than a
245 relative pathname, to be returned. Note that FULL implies MUST-MATCH.
246 Optional sixth argument FILTER can be used to provide a function to
247 filter the completions. This function is passed the filename, and should
248 return a transformed filename (possibly a null transformation) or nil,
249 indicating that the filename should not be included in the completions."
250 (let* ((read-library-internal-search-path SEARCH-PATH)
251 (library (completing-read PROMPT 'read-library-internal
252 FILTER (or MUST-MATCH FULL) nil)))
254 ((equal library "") DEFAULT)
255 (FULL (locate-file library read-library-internal-search-path
256 '(".el" ".el.gz" ".elc")))
259 (defun read-library-name (prompt)
260 "PROMPTs for and returns an existing Elisp library name (without any suffix) or the empty string."
262 (declare (special read-library-internal-search-path))
263 (let ((read-library-internal-search-path load-path))
264 (completing-read prompt
265 'read-library-internal
268 ((string-match #r"\.el\(\.gz\|\.Z\)?$" fn)
269 (substring fn 0 (match-beginning 0)))))
272 ;; NOTE: as a special case, read-library may be used to read a filename
273 ;; relative to the current directory, returning a *relative* pathname
274 ;; (read-file-name returns a full pathname).
276 ;; eg. (read-library "Local header: " '(nil) nil)
278 ;;=== Replacement for load-library with completion ========================
280 (defun load-library (library)
281 "Load the library named LIBRARY.
282 This is an interface to the function `load'."
284 (list (read-library "Load library: " load-path nil nil nil
285 (function (lambda (fn)
287 ((string-match "\\.elc?$" fn)
288 (substring fn 0 (match-beginning 0))))))
292 ;;=== find-library with completion (Author: Bob Weiner) ===================
294 (defun find-library (library &optional codesys display-function)
295 "Find and display in the current window the source for the Elisp LIBRARY.
296 LIBRARY should be a name without any path information and may include or omit
297 the \".el\" suffix. Under XEmacs/Mule, the optional second argument CODESYS
298 specifies the coding system to use when decoding the file. Interactively,
299 with a prefix argument, this prompts for the coding system. Optional third
300 argument DISPLAY-FUNCTION must take two arguments, the filename to display
301 and CODESYS. The default for DISPLAY-FUNCTION is `find-file'."
303 (list (read-library-name "Find library: ")
304 (if current-prefix-arg
305 (read-coding-system "Coding System: "))))
306 (let ((path (if (or (null library) (equal library ""))
308 (locate-file library load-path
309 '("" ".el" ".el.gz" ".el.Z")))))
310 (if path (funcall (if (fboundp display-function)
311 display-function 'find-file)
313 (error "(find-library): Cannot locate library `%s'" library))))
315 (defun find-library-other-window (library &optional codesys)
316 "Find and display in another window the source for the Elisp LIBRARY.
317 LIBRARY should be a name without any path information and may include or omit
318 the \".el\" suffix. Under XEmacs/Mule, the optional second argument CODESYS
319 specifies the coding system to use when decoding the file. Interactively,
320 with a prefix argument, this prompts for the coding system."
322 (list (read-library-name "Find library in other window: ")
323 (if current-prefix-arg
324 (read-coding-system "Coding System: "))))
325 (find-library library codesys 'find-file-other-window))
327 (defun find-library-other-frame (library &optional codesys)
328 "Find and display in another frame the source for the Elisp LIBRARY.
329 LIBRARY should be a name without any path information and may include or omit
330 the \".el\" suffix. Under XEmacs/Mule, the optional second argument CODESYS
331 specifies the coding system to use when decoding the file. Interactively,
332 with a prefix argument, this prompts for the coding system."
334 (list (read-library-name "Find library in other frame: ")
335 (if current-prefix-arg
336 (read-coding-system "Coding System: "))))
337 (find-library library codesys 'find-file-other-frame))
339 ;; This conflicts with an existing binding.
340 ;;(define-key global-map "\C-xl" 'find-library)
341 (define-key global-map "\C-x4l" 'find-library-other-window)
342 (define-key global-map "\C-x5l" 'find-library-other-frame)
344 (provide 'lib-complete)
346 ;;; lib-complete.el ends here