read-file-name.el

   1 ;;; read-file-name --- improved read-file-name with better callbacks
   2
   3 ;; Copyright 2004 Gary V. Vaughan (gary AT gnu DOT org)
   4
   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
  14
  15 ;; This file is not part of GNU Emacs.
  16
  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.
  21 ;;
  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.
  26 ;;
  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.
  31
  32 ;;; Commentary:
  33
  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.
  40 ;;
  41 ;; This file implements `completing-read-file-name', designed to be a
  42 ;; semantic equivalent to CVS GNU Emacs' 7 parameter `read-file-name'.
  43
  44 ;; For example, to implement the reading of a non-existent file:
  45 ;;
  46 ;; (require 'read-file-name)
  47 ;;
  48 ;; (defvar file-not-exists-directory nil)
  49 ;;
  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))
  64 ;;
  65 ;; (defun file-not-exists-p (cons-cell)
  66 ;;   (not (file-exists-p (concat file-not-exists-directory (car cons-cell)))))
  67
  68 ;;; Code:
  69
  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.")
  84
  85 (defvar completing-read-file-name-directory nil
  86   "The path to the root directory of this completion attempt.")
  87
  88 (defvar completing-read-file-name-prompt nil
  89   "The prompt string to show in the minibuffer during reading.")
  90
  91 (defvar completing-read-file-name-predicate nil
  92   "The predicate function used to narrow the completion alist.")
  93
  94
  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))
 136
 137
 138 (defvar completing-read-file-name-complete-word nil
 139   "Whether to limit this completion attempt to word constituent characters.")
 140
 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)))
 145
 146
 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)))
 170
 171            ;; try-completion returns t if file-name is a unique exact match
 172            (exact-p (eq completion t)))
 173
 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))
 179
 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 "/")))
 186
 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)))
 191
 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))
 197
 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))))))
 210
 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)))))
 216
 217
 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)))
 224
 225
 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)))
 243
 244       (with-output-to-temp-buffer "*Completions*"
 245         (display-completion-list
 246          (all-completions file-name alist))))))
 247
 248
 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))
 264
 265 (provide 'read-file-name)
 266
 267 ;;; read-file-name.el ends here