cgit.sxemacs.org Git - sxemacs/blob - 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: SXEmacs Development Team
   8 ;; Keywords: lisp, extensions, dumped
   9 ;; Created: Sat Apr 20 17:47:21 1991
  10
  11 ;; This file is part of SXEmacs.
  12
  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.
  17
  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.
  22
  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/>.
  25
  26 ;;; Synched up with: Not in FSF.
  27
  28 ;;; Commentary:
  29
  30 ;; This file is dumped with SXEmacs.
  31
  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.
  41 ;;
  42 ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
  43 ;;
  44 ;; Keywords: utility, lisp
  45
  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
  54 ;;; ChangeLog:
  55
  56 ;; 4/26/97: sb Mule-ize.
  57 ;; 6/24/1999 much rewriting from Bob Weiner
  58
  59 ;;; Code:
  60
  61 ;;=== Determine completions for filename in search path ===================
  62
  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
  72       (progn
  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))
  78           all-completions)
  79       ;; Make list of completions in each directory on SEARCH-PATH
  80       (while SEARCH-PATH
  81         (let* ((dir (concat (file-name-as-directory
  82                              (expand-file-name (car SEARCH-PATH)))
  83                             subdir))
  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
  89                   (setq all-completions
  90                         (cons (concat dir-prefix (car subdir-completions))
  91                               all-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<)))
  96               compressed)
  97           (while sorted
  98             (if (equal (car sorted) (car compressed)) nil
  99               (setq compressed (cons (car sorted) compressed)))
 100             (setq sorted (cdr sorted)))
 101           compressed)))))
 102
 103 ;;=== Utilities ===========================================================
 104
 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))
 110        (save-excursion
 111          (goto-char (point-max))
 112          (let ((orig-pmax (point-max)))
 113            (unwind-protect
 114                (progn
 115                  (insert " " ,message) (goto-char orig-pmax)
 116                  (sit-for 0)            ; Redisplay
 117                  ,@forms)
 118              (delete-region orig-pmax (point-max)))))
 119      (prog2
 120          (message "%s" ,message)
 121          (progn ,@forms)
 122        (message ""))))
 123
 124 (put 'progn-with-message 'lisp-indent-hook 1)
 125
 126 ;;=== Completion caching ==================================================
 127
 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
 132
 133     ([<path> <subdir>] <cache-record> <cache-record> ...)
 134
 135 where each <cache-record> has the form
 136
 137    (<root> <modtimes> <completion-table>)")
 138
 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))
 142        (string-match
 143         (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
 144         ROOT2)))
 145
 146 (defun lib-complete:get-completion-table (FILE PATH FILTER)
 147   (let* ((subdir (file-name-directory FILE))
 148          (root (file-name-nondirectory FILE))
 149          (PATH
 150           (mapcar
 151            (function (lambda (dir) (file-name-as-directory
 152                                     (expand-file-name (or dir "")))))
 153            PATH))
 154          (key (vector PATH subdir FILTER))
 155          (real-dirs
 156           (if subdir
 157               (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
 158             PATH))
 159          (path-modtimes
 160           (mapcar
 161            (function (lambda (fn) (if fn (nth 5 (file-attributes fn)))))
 162            real-dirs))
 163          (cache-entry (assoc key lib-complete:cache))
 164          (cache-records (cdr cache-entry)))
 165     ;; Look for cached entry
 166     (catch 'table
 167       (while cache-records
 168         (if (and
 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
 179           (let ((completion
 180                  (if (or (not FILTER)
 181                          (file-directory-p (car completion-list)))
 182                      (car completion-list)
 183                    (funcall FILTER (car completion-list)))))
 184             (if completion
 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)
 190         completion-table))))
 191
 192 (defvar lib-complete:max-cache-size 40
 193   "*Maximum number of search paths which are cached.")
 194
 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
 203       (while cache-records
 204         (if (or (equal root (nth 0 (car cache-records)))
 205                 (lib-complete:better-root root (nth 0 (car cache-records))))
 206             nil
 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))
 213     ;; Trim cache
 214     (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
 215       (if tail (setcdr tail nil)))))
 216
 217 ;;=== Read a filename, with completion in a search path ===================
 218
 219 (defun read-library-internal (FILE FILTER FLAG)
 220   "Don't call this."
 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)))
 226     (cond
 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))
 233      )))
 234
 235 (defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH
 236                             FULL FILTER)
 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)))
 253     (cond
 254      ((equal library "") DEFAULT)
 255      (FULL (locate-file library read-library-internal-search-path
 256                          '(".el" ".el.gz" ".elc")))
 257      (t library))))
 258
 259 (defun read-library-name (prompt)
 260   "PROMPTs for and returns an existing Elisp library name (without any suffix) or the empty string."
 261   (interactive)
 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
 266                      (lambda (fn)
 267                        (cond
 268                         ((string-match #r"\.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")))))
 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