git.chise.org Git - chise/xemacs-chise.git.1/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: 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 ;; RCS Info        : $Revision: 1.3.2.1 $ $Locker:  $
  42 ;; ========================================================================
  43 ;; NOTE: XEmacs must be redumped if this file is changed.
  44 ;;
  45 ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
  46 ;;
  47 ;; Keywords: utility, lisp
  48
  49 ;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his
  50 ;; helpful suggestions.
  51
  52 ;; The function locate-file is removed, because of its incompatibility
  53 ;; with the buildin function of the lemacs 19.10 (Heiko M|nkel).
  54
  55 ;; There is now the new function find-library in this package.
  56
  57 ;;; ChangeLog:
  58
  59 ;; 4/26/97: sb Mule-ize.
  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 (defvar read-library-internal-search-path)
 221
 222 (defun read-library-internal (FILE FILTER FLAG)
 223   "Don't call this."
 224   ;; Relies on read-library-internal-search-path being let-bound
 225   (let ((completion-table
 226          (lib-complete:get-completion-table
 227           FILE read-library-internal-search-path FILTER)))
 228     (cond
 229      ((not completion-table) nil)
 230      ;; Completion table is filtered before use, so the PREDICATE
 231      ;; argument is redundant.
 232      ((eq FLAG nil) (try-completion FILE completion-table nil))
 233      ((eq FLAG t) (all-completions FILE completion-table nil))
 234      ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
 235      )))
 236
 237 (defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH
 238                             FULL FILTER)
 239   "Read library name, prompting with PROMPT and completing in directories
 240 from SEARCH-PATH.  A nil in the search path represents the current
 241 directory.  Completions for a given search-path are cached, with the
 242 cache being invalidated whenever one of the directories on the path changes.
 243 Default to DEFAULT if user enters a null string.
 244 Optional fourth arg MUST-MATCH non-nil means require existing file's name.
 245   Non-nil and non-t means also require confirmation after completion.
 246 Optional fifth argument FULL non-nil causes a full pathname, rather than a
 247   relative pathname, to be returned.  Note that FULL implies MUST-MATCH.
 248 Optional sixth argument FILTER can be used to provide a function to
 249   filter the completions.  This function is passed the filename, and should
 250   return a transformed filename (possibly a null transformation) or nil,
 251   indicating that the filename should not be included in the completions."
 252   (let* ((read-library-internal-search-path SEARCH-PATH)
 253          (library (completing-read PROMPT 'read-library-internal
 254                                    FILTER (or MUST-MATCH FULL) nil)))
 255     (cond
 256      ((equal library "") DEFAULT)
 257      (FULL (locate-file library read-library-internal-search-path
 258                           '(".el" ".el.gz" ".elc")))
 259      (t library))))
 260
 261 ;; NOTE: as a special case, read-library may be used to read a filename
 262 ;; relative to the current directory, returning a *relative* pathname
 263 ;; (read-file-name returns a full pathname).
 264 ;;
 265 ;; eg. (read-library "Local header: " '(nil) nil)
 266
 267 (defun get-library-path ()
 268   "Front end to read-library"
 269   (read-library "Find Library file: " load-path nil t t
 270                   (function (lambda (fn)
 271                               (cond
 272                                ;; decompression doesn't work with mule -slb
 273                                ((string-match (if (featurep 'mule)
 274                                                   "\\.el$"
 275                                                 "\\.el\\(\\.gz\\)?$") fn)
 276                                 (substring fn 0 (match-beginning 0))))))
 277                   ))
 278
 279 ;;=== Replacement for load-library with completion ========================
 280
 281 (defun load-library (library)
 282   "Load the library named LIBRARY.
 283 This is an interface to the function `load'."
 284   (interactive
 285    (list (read-library "Load Library: " load-path nil nil nil
 286                   (function (lambda (fn)
 287                               (cond
 288                                ((string-match "\\.elc?$" fn)
 289                                 (substring fn 0 (match-beginning 0))))))
 290                   )))
 291   (load library))
 292
 293 ;;=== find-library with completion (Author: Heiko Muenkel) ===================
 294
 295 (defun find-library (library &optional codesys)
 296   "Find and edit the source for the library named LIBRARY.
 297 The extension of the LIBRARY must be omitted.
 298 Under XEmacs/Mule, the optional second argument specifies the
 299 coding system to use when decoding the file.  Interactively,
 300 with a prefix argument, you will be prompted for the coding system."
 301   (interactive
 302    (list (get-library-path)
 303          (if current-prefix-arg
 304              (read-coding-system "Coding System: "))))
 305   (find-file library codesys))
 306
 307 (defun find-library-other-window (library &optional codesys)
 308   "Load the library named LIBRARY in another window.
 309 Under XEmacs/Mule, the optional second argument specifies the
 310 coding system to use when decoding the file.  Interactively,
 311 with a prefix argument, you will be prompted for the coding system."
 312   (interactive
 313    (list (get-library-path)
 314          (if current-prefix-arg
 315            (read-coding-system "Coding System: "))))
 316   (find-file-other-window library codesys))
 317
 318 (defun find-library-other-frame (library &optional codesys)
 319   "Load the library named LIBRARY in a newly-created frame.
 320 Under XEmacs/Mule, the optional second argument specifies the
 321 coding system to use when decoding the file.  Interactively,
 322 with a prefix argument, you will be prompted for the coding system."
 323   (interactive
 324    (list (get-library-path)
 325          (if current-prefix-arg
 326              (read-coding-system "Coding System: "))))
 327   (find-file-other-frame library codesys))
 328
 329 ; This conflicts with an existing binding
 330 ;(define-key global-map "\C-xl" 'find-library)
 331 (define-key global-map "\C-x4l" 'find-library-other-window)
 332 (define-key global-map "\C-x5l" 'find-library-other-frame)
 333
 334 (provide 'lib-complete)
 335
 336 ;;; lib-complete.el ends here