remember.texi: Update copyright notice and version.
[remember-el.git] / read-file-name.el
blobdf6f69a23cbe6edaa9bdc61b2297192814c19417
1 ;;; read-file-name --- improved read-file-name with better callbacks
3 ;; Copyright 2004 Gary V. Vaughan (gary AT gnu DOT org)
5 ;; Emacs Lisp Archive Entry
6 ;; Filename: read-file-name.el
7 ;; Version: 0.3
8 ;; Date: Wed, 27 May 2004
9 ;; Keywords: minibuffer file-name completion
10 ;; Author: Gary V. Vaughan (gary AT gnu DOT org)
11 ;; Maintainer: Gary V. Vaughan (gary AT gnu DOT org)
12 ;; Description: Improved read-file-name with better callbacks
13 ;; URL: http://tkd.kicks-ass.net/arch/gary@gnu.org--2004/remember--gary--1.0
15 ;; This file is not part of GNU Emacs.
17 ;; This is free software; you can redistribute it and/or modify it under
18 ;; the terms of the GNU General Public License as published by the Free
19 ;; Software Foundation; either version 2, or (at your option) any later
20 ;; version.
22 ;; This is distributed in the hope that it will be useful, but WITHOUT
23 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
24 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
25 ;; for more details.
27 ;; You should have received a copy of the GNU General Public License
28 ;; along with GNU Emacs; see the file COPYING. If not, write to the
29 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
30 ;; MA 02111-1307, USA.
32 ;;; Commentary:
34 ;; There are no high level functions to read the name of a non-existent
35 ;; file from the minibuffer in emacs. CVS GNU Emacs has added two new
36 ;; parameters to `read-file-name' to make writing such a function easier:
37 ;; the new 6th parameter is HIST, to match XEmacs' footprint for that
38 ;; function; the new 7th parameter is PREDICATE, the name of a predicate
39 ;; used to test each candidate file.
41 ;; This file implements `completing-read-file-name', designed to be a
42 ;; semantic equivalent to CVS GNU Emacs' 7 parameter `read-file-name'.
44 ;; For example, to implement the reading of a non-existent file:
46 ;; (require 'read-file-name)
48 ;; (defvar file-not-exists-directory nil)
50 ;; (defun read-file-not-exists (prompt &optional dir default hist)
51 ;; (let ((file-not-exists-directory
52 ;; (abbreviate-file-name
53 ;; (or dir (file-name-directory (buffer-file-name)))))
54 ;; initial)
55 ;; (while (file-exists-p
56 ;; (setq initial
57 ;; (completing-read-file-name prompt dir default nil initial
58 ;; hist 'file-not-exists-p)))
59 ;; (setq dir (file-name-directory initial)
60 ;; initial (file-name-nondirectory initial))
61 ;; (message "%s%s%s [File exists]" prompt dir initial)
62 ;; (sit-for 1))
63 ;; initial))
65 ;; (defun file-not-exists-p (cons-cell)
66 ;; (not (file-exists-p (concat file-not-exists-directory (car cons-cell)))))
68 ;;; Code:
70 (defvar completing-read-file-name-keymap
71 (let ((map (make-sparse-keymap)))
72 (define-key map "?" 'completing-read-file-name-complete-help)
73 (define-key map " " 'completing-read-file-name-complete-word)
74 (define-key map "\C-i" 'completing-read-file-name-complete)
75 (define-key map "\C-g" 'abort-recursive-edit)
76 (define-key map "\C-m" 'exit-minibuffer)
77 (define-key map "\C-j" 'exit-minibuffer)
78 (define-key map [down] 'next-history-element)
79 (define-key map [up] 'previous-history-element)
80 (define-key map "\M-n" 'next-history-element)
81 (define-key map "\M-p" 'previous-history-element)
82 map)
83 "Keymap for reading a file name from the minibuffer with completion.")
85 (defvar completing-read-file-name-directory nil
86 "The path to the root directory of this completion attempt.")
88 (defvar completing-read-file-name-prompt nil
89 "The prompt string to show in the minibuffer during reading.")
91 (defvar completing-read-file-name-predicate nil
92 "The predicate function used to narrow the completion alist.")
95 (defun completing-read-file-name (prompt &optional dir default
96 mustmatch initial hist predicate)
97 "Read file name, prompting with PROMPT and completing in directory DIR.
98 DIR defaults to current buffer's directory default.
99 If `insert-default-directory' is non-nil then DIR is inserted before point
100 in the minibuffer, ready for editing.
101 Default name to DEFAULT if user enters a null string.
102 (If DEFAULT is omitted, the visited file name is used,
103 except that if INITIAL is specified, that combined with DIR is used.)
104 Optional fourth arg MUSTMATCH non-nil means require existing file's name.
105 Non-nil and non-t means also require confirmation after completion.
106 Optional fifth arg INITIAL specifies text to start with.
107 Optional sixth arg HIST, if non-nil, is a symbol that is the history list
108 variable to use.
109 If Optional seventh argument is non-nil, it is used to test each possible
110 match. The match is a candidate only if PREDICATE returns non-nil.
111 See `try-completion' for more details on PREDICATE,
112 Value is not expanded---you must call `expand-file-name' yourself."
113 (let ((keymap completing-read-file-name-keymap)
114 (directory (abbreviate-file-name
115 (or dir (file-name-directory (buffer-file-name)))))
116 file-name)
117 (while
118 (let ((completing-read-file-name-directory directory)
119 (completing-read-file-name-prompt prompt)
120 (completing-read-file-name-predicate predicate)
121 default-file-name)
122 (setq default-file-name (if insert-default-directory
123 (cons (concat directory initial)
124 (1+ (length directory)))
125 initial))
126 (setq file-name
127 (read-from-minibuffer prompt default-file-name
128 keymap nil hist default))
129 (when mustmatch
130 (unless (file-exists-p file-name)
131 (message "%s%s%s [No match]" prompt
132 (if insert-default-directory directory "") initial)
133 (setq file-name (file-relative-name file-name directory))
134 (sit-for 2)))))
135 file-name))
138 (defvar completing-read-file-name-complete-word nil
139 "Whether to limit this completion attempt to word constituent characters.")
141 (defun completing-read-file-name-complete-word ()
142 (interactive)
143 (let ((completing-read-file-name-complete-word t))
144 (completing-read-file-name-complete)))
147 (defun completing-read-file-name-complete ()
148 (interactive)
149 (save-match-data
150 (let* ((prompt completing-read-file-name-prompt)
151 (prompt-re (concat "^" (regexp-quote prompt)))
152 (predicate completing-read-file-name-predicate)
153 (raw-string (buffer-string))
154 (field-start (progn (string-match prompt-re raw-string)
155 (match-end 0)))
156 (minibuffer-string (substring raw-string field-start))
157 (prefix-string (file-name-directory minibuffer-string))
158 (directory
159 (substitute-in-file-name
160 (concat (directory-file-name completing-read-file-name-directory)
161 "/" prefix-string)))
162 (file-name (file-name-nondirectory minibuffer-string))
163 (alist (completing-read-file-name-complete-alist directory))
164 (ignore-re (completing-read-file-name-ignored-extensions))
165 (completion (progn
166 (dolist (elt alist)
167 (if (string-match ignore-re (car elt))
168 (assq-delete-all (car elt) alist)))
169 (try-completion file-name alist predicate)))
171 ;; try-completion returns t if file-name is a unique exact match
172 (exact-p (eq completion t)))
174 (when exact-p
175 (setq completion file-name)
176 (message "%s%s%s [Sole completion]" prompt
177 prefix-string file-name)
178 (sit-for 1))
180 ;; add a trailing slash to directory names if necessary
181 (if (and (< 0 (length completion))
182 (not (string-equal "/" (substring completion -1)))
183 (file-directory-p
184 (substitute-in-file-name (concat directory completion))))
185 (setq completion (concat completion "/")))
187 ;; if there is no change to the minibuffer go in to help
188 (let ((completion-string (or completion "")))
189 (if (and (not exact-p) (string= file-name completion-string))
190 (completing-read-file-name-complete-help)))
192 ;; warn if the minibuffer cannot be completed from ALIST
193 (when (null completion)
194 (message "%s%s%s [No match]" prompt
195 prefix-string file-name)
196 (sit-for 1))
198 ;; limit completion to word constituent chars only if necessary
199 ;; this normally fires when completing on word boundaries with [SPC]
200 (when (and completing-read-file-name-complete-word
201 (> (length completion) (length file-name)))
202 (string-match (concat "^" (regexp-quote file-name)) completion)
203 (let ((additional (substring completion (match-end 0))))
204 (string-match "\\(^\\w*\\)\\(\\W\\|$\\)" additional)
205 (setq completion
206 (concat file-name
207 (if (string= "" (match-string 1 additional))
208 (match-string 2 additional)
209 (match-string 1 additional))))))
211 ;; put the new contents back in the minibuffer
212 (if (> (length completion) (length file-name))
213 (setq file-name (substitute-in-file-name completion)))
214 (delete-region (1+ field-start) (point-max))
215 (insert (concat prefix-string file-name)))))
218 (defun completing-read-file-name-ignored-extensions ()
219 "Return a regexp to match files from `completion-ignored-extensions'."
220 (let (re ext)
221 (dolist (ext completion-ignored-extensions)
222 (setq re (concat (and re (concat re "\\|")) (regexp-quote ext))))
223 (format "\\(%s\\)$" re)))
226 (defun completing-read-file-name-complete-help ()
227 "Show the available completions for current minibuffer contents."
228 (interactive)
229 (save-match-data
230 (let* ((prompt completing-read-file-name-prompt)
231 (prompt-re (concat "^" (regexp-quote prompt)))
232 (raw-string (buffer-string))
233 (field-start (progn (string-match prompt-re raw-string)
234 (match-end 0)))
235 (minibuffer-string (substring raw-string field-start))
236 (prefix-string (file-name-directory minibuffer-string))
237 (directory
238 (substitute-in-file-name
239 (concat (directory-file-name completing-read-file-name-directory)
240 "/" prefix-string)))
241 (file-name (file-name-nondirectory minibuffer-string))
242 (alist (completing-read-file-name-complete-alist directory)))
244 (with-output-to-temp-buffer "*Completions*"
245 (display-completion-list
246 (all-completions file-name alist))))))
249 (defun completing-read-file-name-complete-alist (dir)
250 "Generate an alist of files in DIR suitable for `try-completion'."
251 (let ((file-list (directory-files (expand-file-name dir)))
252 (i 1)
253 alist)
254 (dolist (file file-list)
255 ;; skip . and ..
256 (unless (or (string-equal file ".") (string-equal file ".."))
257 ;; add / to directories
258 (when (file-directory-p (concat (directory-file-name dir) "/" file))
259 (setq file (concat file "/")))
260 (let ((next (list (cons file i))))
261 (setq alist (if alist (append alist next) next)
262 i (1+ i)))))
263 alist))
265 (provide 'read-file-name)
267 ;;; read-file-name.el ends here