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