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