home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / misc / lib-complete.el < prev    next >
Encoding:
Text File  |  1991-06-19  |  12.2 KB  |  320 lines
  1. ; Path: dg-rtp!rock.concert.net!mcnc!stanford.edu!agate!spool.mu.edu!olivea!uunet!comp.vuw.ac.nz!waikato.ac.nz!aukuni.ac.nz!mike-w
  2. ; From: mike-w@cs.aukuni.ac.nz (Mike Williams)
  3. ; Newsgroups: gnu.emacs.sources
  4. ; Subject: UPDATE: lib-complete.el
  5. ; Date: 20 Jun 91 16:41:53 GMT
  6. ; Organization: University of Auckland, New Zealand.
  7. ; Nntp-Posting-Host: cs17.cs.aukuni.ac.nz
  8. ; X-News-Software: GNUS 3.13
  9. ; 
  10. ; 
  11. ;   Here's an update of the recently posted lib-complete.el, with improved
  12. ;   caching, several bug-fixes, and a generally better outlook on life :-)
  13. ;   It incorporates several ideas from Hallvard Furuseth's load-library.el.
  14. ; 
  15. ;; ========================================================================
  16. ;; lib-complete.el --  Completion on a search path
  17. ;; Author          : Mike Williams <mike-w@cs.aukuni.ac.nz>
  18. ;; Created On      : Sat Apr 20 17:47:21 1991
  19. ;; Last Modified By: Mike Williams
  20. ;; Last Modified On: Tue Jun 18 12:53:08 1991
  21. ;; RCS Info        : $Revision: 1.7 $ $Locker:  $
  22. ;; ========================================================================
  23. ;; NOTE: this file must be recompiled if changed.
  24. ;;
  25. ;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
  26. ;;
  27. ;; LCD Archive Entry:
  28. ;; lib-complete|Mike Williams|mike-w@cs.aukuni.ac.nz
  29. ;; |Completion on a search path
  30. ;; |91-06-20|1.7|~/misc/lib-complete.el.Z
  31. ;;
  32. ;; This file is not part of GNU Emacs, but is made available under the
  33. ;; same conditions.
  34. ;;
  35. ;; GNU Emacs is distributed in the hope that it will be useful,
  36. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  37. ;; accepts responsibility to anyone for the consequences of using it
  38. ;; or for whether it serves any particular purpose or works at all,
  39. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  40. ;; License for full details.
  41. ;;
  42. ;; Everyone is granted permission to copy, modify and redistribute
  43. ;; GNU Emacs, but only under the conditions described in the
  44. ;; GNU Emacs General Public License.   A copy of this license is
  45. ;; supposed to have been given to you along with GNU Emacs so you
  46. ;; can know your rights and responsibilities.  It should be in a
  47. ;; file named COPYING.  Among other things, the copyright notice
  48. ;; and this notice must be preserved on all copies.
  49.  
  50. ;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his
  51. ;; helpful suggestions.
  52.  
  53. (provide 'lib-complete)
  54.  
  55. ;; LCD Archive Entry:
  56. ;; lib-complete|Mike Williams|mike-w@cs.aukuni.ac.nz
  57. ;; |Completion on a search path
  58. ;; |91-04-20|$Revision: 1.7 $|
  59.  
  60. ;;=== Usage ===============================================================
  61. ;; 
  62. ;; (autoload (fmakunbound 'load-library) "lib-complete" nil t)
  63. ;; (autoload 'locate-file "lib-complete" nil t)
  64. ;; (autoload 'library-all-completions "lib-complete")
  65. ;; (autoload 'read-library "lib-complete")
  66.  
  67. ;;=== Locate a file in a search path ======================================
  68.  
  69. (defun locate-file (FILE SEARCH-PATH &optional SUFFIX-LIST PRED)
  70.   "Search for FILE on SEARCH-PATH (list).  If optional SUFFIX-LIST is
  71. provided, allow file to be followed by one of the suffixes.
  72. Optional second argument PRED restricts the number of files which
  73. may match.  The default is file-exists-p."
  74.   (if (not SUFFIX-LIST) (setq SUFFIX-LIST '("")))
  75.   (if (not PRED) (setq PRED 'file-exists-p))
  76.   (if (file-name-absolute-p FILE) (setq SEARCH-PATH '(nil)))
  77.   (if (equal FILE "") (error "Empty filename"))
  78.   (let ((filelist 
  79.      (mapcar 
  80.       (function (lambda (ext) (concat FILE ext)))
  81.       SUFFIX-LIST)))
  82.     ;; Search SEARCH-PATH for a readable file in filelist
  83.     (catch 'found
  84.       (while SEARCH-PATH
  85.     (let ((filelist filelist))
  86.       (while filelist
  87.         (let ((filepath (expand-file-name (car filelist) 
  88.                           (car SEARCH-PATH))))
  89.           (if (funcall PRED filepath)
  90.           (throw 'found filepath)))
  91.         (setq filelist (cdr filelist))))
  92.     (setq SEARCH-PATH (cdr SEARCH-PATH))))
  93.     ))
  94.  
  95. ;;=== Determine completions for filename in search path ===================
  96.  
  97. (defun library-all-completions (FILE SEARCH-PATH &optional FULL FAST)
  98.   "Return all completions for FILE in any directory on SEARCH-PATH.
  99. If optional third argument FULL is non-nil, returned pathnames should be 
  100.   absolute rather than relative to some directory on the SEARCH-PATH.
  101. If optional fourth argument FAST is non-nil, don't sort the completions,
  102.   or remove duplicates."
  103.   (setq FILE (or FILE ""))
  104.   (if (file-name-absolute-p FILE)
  105.       ;; It's an absolute file name, so don't need SEARCH-PATH
  106.       (progn
  107.     (setq FILE (expand-file-name FILE))
  108.     (file-name-all-completions 
  109.      (file-name-nondirectory FILE) (file-name-directory FILE)))
  110.     (let ((subdir (file-name-directory FILE))
  111.       (file (file-name-nondirectory FILE))
  112.       all-completions)
  113.       ;; Make list of completions in each directory on SEARCH-PATH
  114.       (while SEARCH-PATH
  115.     (let* ((dir (concat (file-name-as-directory 
  116.                  (expand-file-name (car SEARCH-PATH)))
  117.                 subdir))
  118.            (dir-prefix (if FULL dir subdir)))
  119.       (if (file-directory-p dir)
  120.           (let ((subdir-completions 
  121.              (file-name-all-completions file dir)))
  122.         (while subdir-completions
  123.           (setq all-completions 
  124.             (cons (concat dir-prefix (car subdir-completions))
  125.                   all-completions))
  126.           (setq subdir-completions (cdr subdir-completions))))))
  127.     (setq SEARCH-PATH (cdr SEARCH-PATH)))   
  128.       (if FAST all-completions
  129.     (let ((sorted (nreverse (sort all-completions 'string<)))
  130.           compressed)
  131.       (while sorted
  132.         (if (equal (car sorted) (car compressed)) nil
  133.           (setq compressed (cons (car sorted) compressed)))
  134.         (setq sorted (cdr sorted)))
  135.       compressed)))))
  136.  
  137. ;;=== Utilities ===========================================================
  138.  
  139. (defmacro progn-with-message (MESSAGE &rest FORMS)
  140.   "(progn-with-message MESSAGE FORMS ...)
  141. Display MESSAGE and evaluate FORMS, returning value of the last one."
  142.   ;; based on Hallvard Furuseth's funcall-with-message
  143.   (` 
  144.    (if (eq (selected-window) (minibuffer-window))
  145.        (save-excursion
  146.      (goto-char (point-max))
  147.      (let ((orig-pmax (point-max)))
  148.        (unwind-protect
  149.            (progn
  150.          (insert " " (, MESSAGE)) (goto-char orig-pmax)
  151.          (sit-for 0)        ; Redisplay
  152.          (,@ FORMS))
  153.          (delete-region orig-pmax (point-max)))))
  154.      (prog2
  155.       (message "%s" (, MESSAGE))
  156.       (progn (,@ FORMS))
  157.       (message "")))))
  158.  
  159. (put 'progn-with-message 'lisp-indent-hook 1)
  160.  
  161. ;;=== Completion caching ==================================================
  162.  
  163. (defconst lib-complete:cache nil
  164.   "Used within read-library and read-library-internal to prevent 
  165. costly repeated calls to library-all-completions.
  166. Format is a list of lists of the form
  167.  
  168.     ([<path> <subdir>] <cache-record> <cache-record> ...)
  169.  
  170. where each <cache-record> has the form
  171.  
  172.    (<root> <modtimes> <completion-table>)")
  173.  
  174. (defun lib-complete:better-root (ROOT1 ROOT2)
  175.   "Return non-nil if ROOT1 is a superset of ROOT2."
  176.   (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
  177.        (string-match
  178.     (concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
  179.     ROOT2)))
  180.  
  181. (defun lib-complete:get-completion-table (FILE PATH FILTER)
  182.   (let* ((subdir (file-name-directory FILE))
  183.      (root (file-name-nondirectory FILE))
  184.      (PATH 
  185.       (mapcar 
  186.        (function (lambda (dir) (file-name-as-directory
  187.                     (expand-file-name (or dir "")))))
  188.        PATH))
  189.      (key (vector PATH subdir FILTER))
  190.      (real-dirs 
  191.       (if subdir
  192.           (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
  193.         PATH))
  194.      (path-modtimes
  195.       (mapcar 
  196.        (function (lambda (fn) (if fn (nth 5 (file-attributes fn))))) 
  197.        real-dirs))
  198.      (cache-entry (assoc key lib-complete:cache))
  199.      (cache-records (cdr cache-entry)))
  200.     ;; Look for cached entry
  201.     (catch 'table
  202.       (while cache-records
  203.     (if (and 
  204.          (lib-complete:better-root (nth 0 (car cache-records)) root)
  205.          (equal (nth 1 (car cache-records)) path-modtimes))
  206.         (throw 'table (nth 2 (car cache-records))))
  207.     (setq cache-records (cdr cache-records)))
  208.       ;; Otherwise build completions
  209.       (let ((completion-list 
  210.          (progn-with-message "(building completion table...)"
  211.            (library-all-completions FILE PATH nil 'fast)))
  212.         (completion-table (make-vector 127 0)))
  213.     (while completion-list
  214.       (let ((completion
  215.          (if (or (not FILTER) 
  216.              (file-directory-p (car completion-list))) 
  217.              (car completion-list)
  218.            (funcall FILTER (car completion-list)))))
  219.         (if completion
  220.         (intern completion completion-table)))
  221.       (setq completion-list (cdr completion-list)))
  222.     ;; Cache the completions
  223.     (lib-complete:cache-completions key root 
  224.                     path-modtimes completion-table)
  225.     completion-table))))
  226.  
  227. (defvar lib-complete:max-cache-size 20 
  228.   "*Maximum number of search paths which are cached.")
  229.  
  230. (defun lib-complete:cache-completions (KEY ROOT MODTIMES TABLE)
  231.   (let ((cache-entry (assoc key lib-complete:cache))
  232.     (cache-records (cdr cache-entry))
  233.     (new-cache-records (list (list ROOT MODTIMES TABLE))))
  234.     (if (not cache-entry) nil
  235.       ;; Remove old cache entry
  236.       (setq lib-complete:cache (delq cache-entry lib-complete:cache))
  237.       ;; Copy non-redundant entries from old cache entry
  238.       (while cache-records
  239.     (if (or (equal ROOT (nth 0 (car cache-records)))
  240.         (lib-complete:better-root ROOT (nth 0 (car cache-records))))
  241.         nil
  242.       (setq new-cache-records 
  243.         (cons (car cache-records) new-cache-records)))
  244.     (setq cache-records (cdr cache-records))))
  245.     ;; Add entry to front of cache
  246.     (setq lib-complete:cache
  247.       (cons (cons KEY (nreverse new-cache-records)) lib-complete:cache))
  248.     ;; Trim cache
  249.     (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
  250.       (if tail (setcdr tail nil)))))
  251.  
  252. ;;=== Read a filename, with completion in a search path ===================
  253.  
  254. (defun read-library-internal (FILE FILTER FLAG)
  255.   "Don't call this."
  256.   ;; Relies on read-library-internal-search-path being let-bound
  257.   (let ((completion-table
  258.      (lib-complete:get-completion-table
  259.       FILE read-library-internal-search-path FILTER)))
  260.     (cond
  261.      ((not completion-table) nil)
  262.      ;; Completion table is filtered before use, so the PREDICATE
  263.      ;; argument is redundant.
  264.      ((eq FLAG nil) (try-completion FILE completion-table nil))
  265.      ((eq FLAG t) (all-completions FILE completion-table nil))
  266.      ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
  267.      )))
  268.  
  269. (defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH 
  270.                 FULL FILTER)
  271.   "Read library name, prompting with PROMPT and completing in directories
  272. from SEARCH-PATH.  A nil in the search path represents the current
  273. directory.  Completions for a given search-path are cached, with the
  274. cache being invalidated whenever one of the directories on the path changes.
  275. Default to DEFAULT if user enters a null string.
  276. Optional fourth arg MUST-MATCH non-nil means require existing file's name.
  277.   Non-nil and non-t means also require confirmation after completion.
  278. Optional fifth argument FULL non-nil causes a full pathname, rather than a 
  279.   relative pathname, to be returned.  Note that FULL implies MUST-MATCH.
  280. Optional sixth argument FILTER can be used to provide a function to
  281.   filter the completions.  This function is passed the filename, and should
  282.   return a transformed filename (possibly a null transformation) or nil, 
  283.   indicating that the filename should not be included in the completions."
  284.   (let* ((read-library-internal-search-path SEARCH-PATH)
  285.      (library (completing-read PROMPT 'read-library-internal 
  286.                    FILTER (or MUST-MATCH FULL) nil)))
  287.     (cond 
  288.      ((equal library "") DEFAULT)
  289.      (FULL (locate-file library read-library-internal-search-path))
  290.      (t library))))
  291.  
  292. ;; NOTE: as a special case, read-library may be used to read a filename
  293. ;; relative to the current directory, returning a *relative* pathname
  294. ;; (read-file-name returns a full pathname).
  295. ;;
  296. ;; eg. (read-library "Local header: " '(nil) nil)
  297.  
  298. ;;=== Replacement for load-library with completion ========================
  299.  
  300. (defun load-library (LIBRARY)
  301.   "Load the library named LIBRARY."
  302.   (interactive 
  303.    (list 
  304.     (read-library "Load Library: " load-path nil nil nil
  305.           (function (lambda (fn) 
  306.                   (cond 
  307.                    ((string-match "\\.elc?$" fn)
  308.                 (substring fn 0 (match-beginning 0))))))
  309.           )))
  310.   (load LIBRARY))
  311.  
  312. ;;=== END of lib-complete.el ==============================================
  313. --
  314.     /-------------------- mike-w@cs.aukuni.ac.nz ---------------------\
  315.     | Mike Williams, Computer Science, Auckland University, Aotearoa. |
  316.     \-------------- I have a lovely bunch of coconuts. ---------------/
  317.     Disclaimer: I wasn't even there.
  318. -- 
  319. New administrater uofa.
  320.