X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fxemacs-chise.git.1;a=blobdiff_plain;f=lisp%2Flib-complete.el;fp=lisp%2Flib-complete.el;h=83123c6e5f916babf73ca1c75306b6ea400bac27;hp=0000000000000000000000000000000000000000;hb=6883ee56ec887c2c48abe5b06b5e66aa74031910;hpb=5db996688c255b7f4bbe096f935b10d4c4ab7ade diff --git a/lisp/lib-complete.el b/lisp/lib-complete.el new file mode 100644 index 0000000..83123c6 --- /dev/null +++ b/lisp/lib-complete.el @@ -0,0 +1,339 @@ +;;; lib-complete.el --- Completion on the lisp search path + +;; Copyright (C) 1997 Free Software Foundation, Inc. +;; Copyright (C) Mike Williams 1991 + +;; Author: Mike Williams +;; Maintainer: XEmacs Development Team +;; Keywords: lisp, extensions, dumped +;; Created: Sat Apr 20 17:47:21 1991 + +;; 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, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Synched up with: Not in FSF. + +;;; Commentary: + +;; This file is dumped with XEmacs. + +;; ======================================================================== +;; lib-complete.el -- Completion on a search path +;; Author : Mike Williams +;; Created On : Sat Apr 20 17:47:21 1991 +;; Last Modified By: Heiko M|nkel +;; Additional XEmacs integration By: Chuck Thompson +;; Last Modified On: Thu Jul 1 14:23:00 1994 +;; RCS Info : $Revision: 1.3 $ $Locker: $ +;; ======================================================================== +;; NOTE: XEmacs must be redumped if this file is changed. +;; +;; Copyright (C) Mike Williams 1991 +;; +;; Keywords: utility, lisp + +;; Many thanks to Hallvard Furuseth 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. + +;;; ChangeLog: + +;; 4/26/97: sb Mule-ize. + +;;; Code: + +;;=== 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 + + ([ ] ...) + +where each has the form + + ( )") + +(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 40 + "*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 + ;; decompression doesn't work with Mule -slb + (if (featurep 'mule) + ".el:.elc" + ".el:.el.gz:.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 + ;; decompression doesn't work with mule -slb + ((string-match (if (featurep 'mule) + "\\.el$" + "\\.el\\(\\.gz\\)?$") 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 &optional codesys) + "Find and edit the source for the library named LIBRARY. +The extension of the LIBRARY must be omitted. +Under XEmacs/Mule, the optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive + (list (get-library-path) + (if current-prefix-arg + (read-coding-system "Coding System: ")))) + (find-file library codesys)) + +(defun find-library-other-window (library &optional codesys) + "Load the library named LIBRARY in another window. +Under XEmacs/Mule, the optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive + (list (get-library-path) + (if current-prefix-arg + (read-coding-system "Coding System: ")))) + (find-file-other-window library codesys)) + +(defun find-library-other-frame (library &optional codesys) + "Load the library named LIBRARY in a newly-created frame. +Under XEmacs/Mule, the optional second argument specifies the +coding system to use when decoding the file. Interactively, +with a prefix argument, you will be prompted for the coding system." + (interactive + (list (get-library-path) + (if current-prefix-arg + (read-coding-system "Coding System: ")))) + (find-file-other-frame library codesys)) + +; 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) + +(provide 'lib-complete) + +;;; lib-complete.el ends here