Reformatted.
[chise/xemacs-chise.git.1] / lisp / lib-complete.el
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 ;; ========================================================================
42 ;; NOTE: XEmacs must be redumped if this file is changed.
43 ;;
44 ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
45 ;;
46 ;; Keywords: utility, lisp
47
48 ;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his
49 ;; helpful suggestions.
50
51 ;; The function locate-file is removed, because of its incompatibility
52 ;; with the buildin function of the lemacs 19.10 (Heiko M|nkel).
53
54 ;; There is now the new function find-library in this package.
55
56 ;;; ChangeLog:
57
58 ;; 4/26/97: sb Mule-ize.
59 ;; 6/24/1999 much rewriting from Bob Weiner
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   `(if (eq (selected-window) (minibuffer-window))
112        (save-excursion
113          (goto-char (point-max))
114          (let ((orig-pmax (point-max)))
115            (unwind-protect
116                (progn
117                  (insert " " ,message) (goto-char orig-pmax)
118                  (sit-for 0)            ; Redisplay
119                  ,@forms)
120              (delete-region orig-pmax (point-max)))))
121      (prog2
122          (message "%s" ,message)
123          (progn ,@forms)
124        (message ""))))
125
126 (put 'progn-with-message 'lisp-indent-hook 1)
127
128 ;;=== Completion caching ==================================================
129
130 (defconst lib-complete:cache nil
131   "Used within `read-library' and `read-library-internal' to prevent 
132 costly repeated calls to `library-all-completions'.
133 Format is a list of lists of the form
134
135     ([<path> <subdir>] <cache-record> <cache-record> ...)
136
137 where each <cache-record> has the form
138
139    (<root> <modtimes> <completion-table>)")
140
141 (defun lib-complete:better-root (ROOT1 ROOT2)
142   "Return non-nil if ROOT1 is a superset of ROOT2."
143   (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
144        (string-match
145         (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
146         ROOT2)))
147
148 (defun lib-complete:get-completion-table (FILE PATH FILTER)
149   (let* ((subdir (file-name-directory FILE))
150          (root (file-name-nondirectory FILE))
151          (PATH 
152           (mapcar 
153            (function (lambda (dir) (file-name-as-directory
154                                     (expand-file-name (or dir "")))))
155            PATH))
156          (key (vector PATH subdir FILTER))
157          (real-dirs 
158           (if subdir
159               (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
160             PATH))
161          (path-modtimes
162           (mapcar 
163            (function (lambda (fn) (if fn (nth 5 (file-attributes fn))))) 
164            real-dirs))
165          (cache-entry (assoc key lib-complete:cache))
166          (cache-records (cdr cache-entry)))
167     ;; Look for cached entry
168     (catch 'table
169       (while cache-records
170         (if (and 
171              (lib-complete:better-root (nth 0 (car cache-records)) root)
172              (equal (nth 1 (car cache-records)) path-modtimes))
173             (throw 'table (nth 2 (car cache-records))))
174         (setq cache-records (cdr cache-records)))
175       ;; Otherwise build completions
176       (let ((completion-list 
177              (progn-with-message "(building completion table...)"
178                (library-all-completions FILE PATH nil 'fast)))
179             (completion-table (make-vector 127 0)))
180         (while completion-list
181           (let ((completion
182                  (if (or (not FILTER) 
183                          (file-directory-p (car completion-list))) 
184                      (car completion-list)
185                    (funcall FILTER (car completion-list)))))
186             (if completion
187                 (intern completion completion-table)))
188           (setq completion-list (cdr completion-list)))
189         ;; Cache the completions
190         (lib-complete:cache-completions key root 
191                                         path-modtimes completion-table)
192         completion-table))))
193
194 (defvar lib-complete:max-cache-size 40 
195   "*Maximum number of search paths which are cached.")
196
197 (defun lib-complete:cache-completions (key root modtimes table)
198   (let* ((cache-entry (assoc key lib-complete:cache))
199          (cache-records (cdr cache-entry))
200          (new-cache-records (list (list root modtimes table))))
201     (if (not cache-entry) nil
202       ;; Remove old cache entry
203       (setq lib-complete:cache (delq cache-entry lib-complete:cache))
204       ;; Copy non-redundant entries from old cache entry
205       (while cache-records
206         (if (or (equal root (nth 0 (car cache-records)))
207                 (lib-complete:better-root root (nth 0 (car cache-records))))
208             nil
209           (setq new-cache-records 
210                 (cons (car cache-records) new-cache-records)))
211         (setq cache-records (cdr cache-records))))
212     ;; Add entry to front of cache
213     (setq lib-complete:cache
214           (cons (cons key (nreverse new-cache-records)) lib-complete:cache))
215     ;; Trim cache
216     (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
217       (if tail (setcdr tail nil)))))
218
219 ;;=== Read a filename, with completion in a search path ===================
220
221 (defun read-library-internal (FILE FILTER FLAG)
222   "Don't call this."
223   ;; Relies on read-library-internal-search-path being let-bound
224   (let ((completion-table
225          (lib-complete:get-completion-table
226           FILE read-library-internal-search-path FILTER)))
227     (cond
228      ((not completion-table) nil)
229      ;; Completion table is filtered before use, so the PREDICATE
230      ;; argument is redundant.
231      ((eq FLAG nil) (try-completion FILE completion-table nil))
232      ((eq FLAG t) (all-completions FILE completion-table nil))
233      ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
234      )))
235
236 (defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH 
237                             FULL FILTER)
238   "Read library name, prompting with PROMPT and completing in directories
239 from SEARCH-PATH.  A nil in the search path represents the current
240 directory.  Completions for a given search-path are cached, with the
241 cache being invalidated whenever one of the directories on the path changes.
242 Default to DEFAULT if user enters a null string.
243 Optional fourth arg MUST-MATCH non-nil means require existing file's name.
244   Non-nil and non-t means also require confirmation after completion.
245 Optional fifth argument FULL non-nil causes a full pathname, rather than a 
246   relative pathname, to be returned.  Note that FULL implies MUST-MATCH.
247 Optional sixth argument FILTER can be used to provide a function to
248   filter the completions.  This function is passed the filename, and should
249   return a transformed filename (possibly a null transformation) or nil, 
250   indicating that the filename should not be included in the completions."
251   (let* ((read-library-internal-search-path SEARCH-PATH)
252          (library (completing-read PROMPT 'read-library-internal 
253                                    FILTER (or MUST-MATCH FULL) nil)))
254     (cond 
255      ((equal library "") DEFAULT)
256      (FULL (locate-file library read-library-internal-search-path
257                          '(".el" ".el.gz" ".elc")))
258      (t library))))
259
260 (defun read-library-name (prompt)
261   "PROMPTs for and returns an existing Elisp library name (without any suffix) or the empty string."
262   (interactive)
263   (let ((read-library-internal-search-path load-path))
264     (completing-read prompt
265                      'read-library-internal 
266                      (lambda (fn) 
267                        (cond
268                         ((string-match "\\.el\\(\\.gz\\|\\.Z\\)?$" fn)
269                          (substring fn 0 (match-beginning 0)))))
270                      t nil)))
271
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).
275 ;;
276 ;; eg. (read-library "Local header: " '(nil) nil)
277
278 ;;=== Replacement for load-library with completion ========================
279
280 (defun load-library (library)
281   "Load the library named LIBRARY.
282 This is an interface to the function `load'."
283   (interactive 
284    (list (read-library "Load library: " load-path nil nil nil
285                        (function (lambda (fn) 
286                                    (cond 
287                                     ((string-match "\\.elc?$" fn)
288                                      (substring fn 0 (match-beginning 0))))))
289                        ))) 
290   (load library))
291
292 ;;=== find-library with completion (Author: Bob Weiner) ===================
293
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'."
302   (interactive 
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 ""))
307                    nil
308                 (locate-file library load-path
309                                ":.el:.el.gz:.el.Z:.elc"))))
310     (if path (funcall (if (fboundp display-function)
311                           display-function 'find-file)
312                       path codesys)
313       (error "(find-library): Cannot locate library `%s'" library))))
314
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."
321   (interactive 
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))
326
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."
333   (interactive 
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))
338
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)
343
344 (provide 'lib-complete)
345
346 ;;; lib-complete.el ends here