--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/utils/lib-complete.el	Mon Aug 13 08:45:50 2007 +0200
@@ -0,0 +1,332 @@
+;; ========================================================================
+;; lib-complete.el --  Completion on a search path
+;; Author          : Mike Williams <mike-w@cs.aukuni.ac.nz>
+;; Created On      : Sat Apr 20 17:47:21 1991
+;; Last Modified By: Heiko M|nkel <muenkel@tnt.uni-hannover.de>
+;; Additional XEmacs integration By: Chuck Thompson <cthomp@cs.uiuc.edu>
+;; Last Modified On: Thu Jul 1 14:23:00 1994
+;; RCS Info        : $Revision: 1.1.1.1 $ $Locker:  $
+;; ========================================================================
+;; NOTE: this file must be recompiled if changed.
+;;
+;; Copyright (C) Mike Williams <mike-w@cs.aukuni.ac.nz> 1991
+;;
+;; Keywords: utility, lisp
+
+;; This file is part of XEmacs.
+
+;; XEmacs is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+
+;; XEmacs is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with XEmacs; see the file COPYING.  If not, write to the Free
+;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Synched up with: Not in FSF.
+
+;; Many thanks to Hallvard Furuseth <hallvard@ifi.uio.no> for his
+;; helpful suggestions.
+
+;; The function locate-file is removed, because of its incompatibility
+;; with the buildin function of the lemacs 19.10 (Heiko M|nkel).
+
+;; There is now the new function find-library in this package.
+
+(provide 'lib-complete)
+
+;;=== Usage ===============================================================
+;; 
+;; (autoload (fmakunbound 'load-library) "lib-complete" nil t)
+;; (autoload 'library-all-completions "lib-complete")
+;; (autoload 'read-library "lib-complete")
+;; (autoload 'find-library "lib-complete"
+;;  "Find and edit the source for the library named LIBRARY.
+;; The extension of the LIBRARY must be omitted.")
+
+;;=== Locate a file in a search path ======================================
+
+;(defun locate-file (FILE SEARCH-PATH &optional SUFFIX-LIST PRED)
+;  "Search for FILE on SEARCH-PATH (list).  If optional SUFFIX-LIST is
+;provided, allow file to be followed by one of the suffixes.
+;Optional second argument PRED restricts the number of files which
+;may match.  The default is file-exists-p."
+;  (if (not SUFFIX-LIST) (setq SUFFIX-LIST '("")))
+;  (if (not PRED) (setq PRED 'file-exists-p))
+;  (if (file-name-absolute-p FILE) (setq SEARCH-PATH '(nil)))
+;  (if (equal FILE "") (error "Empty filename"))
+;  (let ((filelist 
+;	 (mapcar 
+;	  (function (lambda (ext) (concat FILE ext)))
+;	  SUFFIX-LIST)))
+;    ;; Search SEARCH-PATH for a readable file in filelist
+;    (catch 'found
+;      (while SEARCH-PATH
+;	(let ((filelist filelist))
+;	  (while filelist
+;	    (let ((filepath (expand-file-name (car filelist) 
+;					      (car SEARCH-PATH))))
+;	      (if (funcall PRED filepath)
+;		  (throw 'found filepath)))
+;	    (setq filelist (cdr filelist))))
+;	(setq SEARCH-PATH (cdr SEARCH-PATH))))
+;    ))
+
+;;=== Determine completions for filename in search path ===================
+
+(defun library-all-completions (FILE SEARCH-PATH &optional FULL FAST)
+  "Return all completions for FILE in any directory on SEARCH-PATH.
+If optional third argument FULL is non-nil, returned pathnames should be 
+  absolute rather than relative to some directory on the SEARCH-PATH.
+If optional fourth argument FAST is non-nil, don't sort the completions,
+  or remove duplicates."
+  (setq FILE (or FILE ""))
+  (if (file-name-absolute-p FILE)
+      ;; It's an absolute file name, so don't need SEARCH-PATH
+      (progn
+	(setq FILE (expand-file-name FILE))
+	(file-name-all-completions 
+	 (file-name-nondirectory FILE) (file-name-directory FILE)))
+    (let ((subdir (file-name-directory FILE))
+	  (file (file-name-nondirectory FILE))
+	  all-completions)
+      ;; Make list of completions in each directory on SEARCH-PATH
+      (while SEARCH-PATH
+	(let* ((dir (concat (file-name-as-directory 
+			     (expand-file-name (car SEARCH-PATH)))
+			    subdir))
+	       (dir-prefix (if FULL dir subdir)))
+	  (if (file-directory-p dir)
+	      (let ((subdir-completions 
+		     (file-name-all-completions file dir)))
+		(while subdir-completions
+		  (setq all-completions 
+			(cons (concat dir-prefix (car subdir-completions))
+			      all-completions))
+		  (setq subdir-completions (cdr subdir-completions))))))
+	(setq SEARCH-PATH (cdr SEARCH-PATH)))   
+      (if FAST all-completions
+	(let ((sorted (nreverse (sort all-completions 'string<)))
+	      compressed)
+	  (while sorted
+	    (if (equal (car sorted) (car compressed)) nil
+	      (setq compressed (cons (car sorted) compressed)))
+	    (setq sorted (cdr sorted)))
+	  compressed)))))
+
+;;=== Utilities ===========================================================
+
+(defmacro progn-with-message (MESSAGE &rest FORMS)
+  "(progn-with-message MESSAGE FORMS ...)
+Display MESSAGE and evaluate FORMS, returning value of the last one."
+  ;; based on Hallvard Furuseth's funcall-with-message
+  (` 
+   (if (eq (selected-window) (minibuffer-window))
+       (save-excursion
+	 (goto-char (point-max))
+	 (let ((orig-pmax (point-max)))
+	   (unwind-protect
+	       (progn
+		 (insert " " (, MESSAGE)) (goto-char orig-pmax)
+		 (sit-for 0)		; Redisplay
+		 (,@ FORMS))
+	     (delete-region orig-pmax (point-max)))))
+     (prog2
+      (message "%s" (, MESSAGE))
+      (progn (,@ FORMS))
+      (message "")))))
+
+(put 'progn-with-message 'lisp-indent-hook 1)
+
+;;=== Completion caching ==================================================
+
+(defconst lib-complete:cache nil
+  "Used within read-library and read-library-internal to prevent 
+costly repeated calls to library-all-completions.
+Format is a list of lists of the form
+
+    ([<path> <subdir>] <cache-record> <cache-record> ...)
+
+where each <cache-record> has the form
+
+   (<root> <modtimes> <completion-table>)")
+
+(defun lib-complete:better-root (ROOT1 ROOT2)
+  "Return non-nil if ROOT1 is a superset of ROOT2."
+  (and (equal (file-name-directory ROOT1) (file-name-directory ROOT2))
+       (string-match
+	(concat "^" (regexp-quote (file-name-nondirectory ROOT1)))
+	ROOT2)))
+
+(defun lib-complete:get-completion-table (FILE PATH FILTER)
+  (let* ((subdir (file-name-directory FILE))
+	 (root (file-name-nondirectory FILE))
+	 (PATH 
+	  (mapcar 
+	   (function (lambda (dir) (file-name-as-directory
+				    (expand-file-name (or dir "")))))
+	   PATH))
+	 (key (vector PATH subdir FILTER))
+	 (real-dirs 
+	  (if subdir
+	      (mapcar (function (lambda (dir) (concat dir subdir))) PATH)
+	    PATH))
+	 (path-modtimes
+	  (mapcar 
+	   (function (lambda (fn) (if fn (nth 5 (file-attributes fn))))) 
+	   real-dirs))
+	 (cache-entry (assoc key lib-complete:cache))
+	 (cache-records (cdr cache-entry)))
+    ;; Look for cached entry
+    (catch 'table
+      (while cache-records
+	(if (and 
+	     (lib-complete:better-root (nth 0 (car cache-records)) root)
+	     (equal (nth 1 (car cache-records)) path-modtimes))
+	    (throw 'table (nth 2 (car cache-records))))
+	(setq cache-records (cdr cache-records)))
+      ;; Otherwise build completions
+      (let ((completion-list 
+	     (progn-with-message "(building completion table...)"
+	       (library-all-completions FILE PATH nil 'fast)))
+	    (completion-table (make-vector 127 0)))
+	(while completion-list
+	  (let ((completion
+		 (if (or (not FILTER) 
+			 (file-directory-p (car completion-list))) 
+		     (car completion-list)
+		   (funcall FILTER (car completion-list)))))
+	    (if completion
+		(intern completion completion-table)))
+	  (setq completion-list (cdr completion-list)))
+	;; Cache the completions
+	(lib-complete:cache-completions key root 
+					path-modtimes completion-table)
+	completion-table))))
+
+(defvar lib-complete:max-cache-size 20 
+  "*Maximum number of search paths which are cached.")
+
+(defun lib-complete:cache-completions (key root modtimes table)
+  (let* ((cache-entry (assoc key lib-complete:cache))
+	 (cache-records (cdr cache-entry))
+	 (new-cache-records (list (list root modtimes table))))
+    (if (not cache-entry) nil
+      ;; Remove old cache entry
+      (setq lib-complete:cache (delq cache-entry lib-complete:cache))
+      ;; Copy non-redundant entries from old cache entry
+      (while cache-records
+	(if (or (equal root (nth 0 (car cache-records)))
+		(lib-complete:better-root root (nth 0 (car cache-records))))
+	    nil
+	  (setq new-cache-records 
+		(cons (car cache-records) new-cache-records)))
+	(setq cache-records (cdr cache-records))))
+    ;; Add entry to front of cache
+    (setq lib-complete:cache
+	  (cons (cons key (nreverse new-cache-records)) lib-complete:cache))
+    ;; Trim cache
+    (let ((tail (nthcdr lib-complete:max-cache-size lib-complete:cache)))
+      (if tail (setcdr tail nil)))))
+
+;;=== Read a filename, with completion in a search path ===================
+
+(defun read-library-internal (FILE FILTER FLAG)
+  "Don't call this."
+  ;; Relies on read-library-internal-search-path being let-bound
+  (let ((completion-table
+	 (lib-complete:get-completion-table
+	  FILE read-library-internal-search-path FILTER)))
+    (cond
+     ((not completion-table) nil)
+     ;; Completion table is filtered before use, so the PREDICATE
+     ;; argument is redundant.
+     ((eq FLAG nil) (try-completion FILE completion-table nil))
+     ((eq FLAG t) (all-completions FILE completion-table nil))
+     ((eq FLAG 'lambda) (and (intern-soft FILE completion-table) t))
+     )))
+
+(defun read-library (PROMPT SEARCH-PATH &optional DEFAULT MUST-MATCH 
+			    FULL FILTER)
+  "Read library name, prompting with PROMPT and completing in directories
+from SEARCH-PATH.  A nil in the search path represents the current
+directory.  Completions for a given search-path are cached, with the
+cache being invalidated whenever one of the directories on the path changes.
+Default to DEFAULT if user enters a null string.
+Optional fourth arg MUST-MATCH non-nil means require existing file's name.
+  Non-nil and non-t means also require confirmation after completion.
+Optional fifth argument FULL non-nil causes a full pathname, rather than a 
+  relative pathname, to be returned.  Note that FULL implies MUST-MATCH.
+Optional sixth argument FILTER can be used to provide a function to
+  filter the completions.  This function is passed the filename, and should
+  return a transformed filename (possibly a null transformation) or nil, 
+  indicating that the filename should not be included in the completions."
+  (let* ((read-library-internal-search-path SEARCH-PATH)
+	 (library (completing-read PROMPT 'read-library-internal 
+				   FILTER (or MUST-MATCH FULL) nil)))
+    (cond 
+     ((equal library "") DEFAULT)
+     (FULL (locate-file library read-library-internal-search-path ".el:.elc"))
+     (t library))))
+
+;; NOTE: as a special case, read-library may be used to read a filename
+;; relative to the current directory, returning a *relative* pathname
+;; (read-file-name returns a full pathname).
+;;
+;; eg. (read-library "Local header: " '(nil) nil)
+
+(defun get-library-path ()
+  "Front end to read-library"
+  (read-library "Find Library file: " load-path nil t t
+		  (function (lambda (fn) 
+			      (cond 
+			       ((string-match "\\.el$" fn)
+				(substring fn 0 (match-beginning 0))))))
+		  ))
+
+;;=== Replacement for load-library with completion ========================
+
+(defun load-library (library)
+  "Load the library named LIBRARY.
+This is an interface to the function `load'."
+  (interactive 
+   (list (read-library "Load Library: " load-path nil nil nil
+		  (function (lambda (fn) 
+			      (cond 
+			       ((string-match "\\.elc?$" fn)
+				(substring fn 0 (match-beginning 0))))))
+		  ))) 
+  (load library))
+
+;;=== find-library with completion (Author: Heiko Muenkel) ===================
+
+(defun find-library (library)
+  "Find and edit the source for the library named LIBRARY.
+The extension of the LIBRARY must be omitted."
+  (interactive 
+   (list 
+    (get-library-path)))
+  (find-file library))
+
+(defun find-library-other-window (library)
+  "Load the library named LIBRARY in another window."
+  (interactive 
+   (list (get-library-path)))
+  (find-file-other-window library))
+
+(defun find-library-other-frame (library)
+  "Load the library named LIBRARY in a newly-created frame."
+  (interactive 
+   (list (get-library-path)))
+  (find-file-other-frame library))
+
+; This conflicts with an existing binding
+;(define-key global-map "\C-xl" 'find-library)
+(define-key global-map "\C-x4l" 'find-library-other-window)
+(define-key global-map "\C-x5l" 'find-library-other-frame)