| 1 | ;;; minibuffer.el --- Minibuffer completion functions |
| 2 | |
| 3 | ;; Copyright (C) 2008-2011 Free Software Foundation, Inc. |
| 4 | |
| 5 | ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> |
| 6 | ;; Package: emacs |
| 7 | |
| 8 | ;; This file is part of GNU Emacs. |
| 9 | |
| 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
| 11 | ;; it under the terms of the GNU General Public License as published by |
| 12 | ;; the Free Software Foundation, either version 3 of the License, or |
| 13 | ;; (at your option) any later version. |
| 14 | |
| 15 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 16 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 17 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 18 | ;; GNU General Public License for more details. |
| 19 | |
| 20 | ;; You should have received a copy of the GNU General Public License |
| 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
| 22 | |
| 23 | ;;; Commentary: |
| 24 | |
| 25 | ;; Names with "--" are for functions and variables that are meant to be for |
| 26 | ;; internal use only. |
| 27 | |
| 28 | ;; Functional completion tables have an extended calling conventions: |
| 29 | ;; - The `action' can be (additionally to nil, t, and lambda) of the form |
| 30 | ;; (boundaries . SUFFIX) in which case it should return |
| 31 | ;; (boundaries START . END). See `completion-boundaries'. |
| 32 | ;; Any other return value should be ignored (so we ignore values returned |
| 33 | ;; from completion tables that don't know about this new `action' form). |
| 34 | |
| 35 | ;;; Bugs: |
| 36 | |
| 37 | ;; - completion-all-sorted-completions list all the completions, whereas |
| 38 | ;; it should only lists the ones that `try-completion' would consider. |
| 39 | ;; E.g. it should honor completion-ignored-extensions. |
| 40 | ;; - choose-completion can't automatically figure out the boundaries |
| 41 | ;; corresponding to the displayed completions because we only |
| 42 | ;; provide the start info but not the end info in |
| 43 | ;; completion-base-position. |
| 44 | ;; - quoting is problematic. E.g. the double-dollar quoting used in |
| 45 | ;; substitute-in-file-name (and hence read-file-name-internal) bumps |
| 46 | ;; into various bugs: |
| 47 | ;; - choose-completion doesn't know how to quote the text it inserts. |
| 48 | ;; E.g. it fails to double the dollars in file-name completion, or |
| 49 | ;; to backslash-escape spaces and other chars in comint completion. |
| 50 | ;; - when completing ~/tmp/fo$$o, the highligting in *Completions* |
| 51 | ;; is off by one position. |
| 52 | ;; - all code like PCM which relies on all-completions to match |
| 53 | ;; its argument gets confused because all-completions returns unquoted |
| 54 | ;; texts (as desired for *Completions* output). |
| 55 | ;; - C-x C-f ~/*/sr ? should not list "~/./src". |
| 56 | ;; - minibuffer-force-complete completes ~/src/emacs/t<!>/lisp/minibuffer.el |
| 57 | ;; to ~/src/emacs/trunk/ and throws away lisp/minibuffer.el. |
| 58 | |
| 59 | ;;; Todo: |
| 60 | |
| 61 | ;; - extend `boundaries' to provide various other meta-data about the |
| 62 | ;; output of `all-completions': |
| 63 | ;; - preferred sorting order when displayed in *Completions*. |
| 64 | ;; - annotations/text-properties to add when displayed in *Completions*. |
| 65 | ;; - quoting/unquoting (so we can complete files names with envvars |
| 66 | ;; and backslashes, and all-completion can list names without |
| 67 | ;; quoting backslashes and dollars). |
| 68 | ;; - indicate how to turn all-completion's output into |
| 69 | ;; try-completion's output: e.g. completion-ignored-extensions. |
| 70 | ;; maybe that could be merged with the "quote" operation above. |
| 71 | ;; - completion hook to run when the completion is |
| 72 | ;; selected/inserted (maybe this should be provided some other |
| 73 | ;; way, e.g. as text-property, so `try-completion can also return it?) |
| 74 | ;; both for when it's inserted via TAB or via choose-completion. |
| 75 | ;; - indicate that `all-completions' doesn't do prefix-completion |
| 76 | ;; but just returns some list that relates in some other way to |
| 77 | ;; the provided string (as is the case in filecache.el), in which |
| 78 | ;; case partial-completion (for example) doesn't make any sense |
| 79 | ;; and neither does the completions-first-difference highlight. |
| 80 | ;; - indicate how to display the completions in *Completions* (turn |
| 81 | ;; \n into something else, add special boundaries between |
| 82 | ;; completions). E.g. when completing from the kill-ring. |
| 83 | |
| 84 | ;; - make partial-completion-mode obsolete: |
| 85 | ;; - (?) <foo.h> style completion for file names. |
| 86 | ;; This can't be done identically just by tweaking completion, |
| 87 | ;; because partial-completion-mode's behavior is to expand <string.h> |
| 88 | ;; to /usr/include/string.h only when exiting the minibuffer, at which |
| 89 | ;; point the completion code is actually not involved normally. |
| 90 | ;; Partial-completion-mode does it via a find-file-not-found-function. |
| 91 | ;; - special code for C-x C-f <> to visit the file ref'd at point |
| 92 | ;; via (require 'foo) or #include "foo". ffap seems like a better |
| 93 | ;; place for this feature (supplemented with major-mode-provided |
| 94 | ;; functions to find the file ref'd at point). |
| 95 | |
| 96 | ;; - case-sensitivity currently confuses two issues: |
| 97 | ;; - whether or not a particular completion table should be case-sensitive |
| 98 | ;; (i.e. whether strings that differ only by case are semantically |
| 99 | ;; equivalent) |
| 100 | ;; - whether the user wants completion to pay attention to case. |
| 101 | ;; e.g. we may want to make it possible for the user to say "first try |
| 102 | ;; completion case-sensitively, and if that fails, try to ignore case". |
| 103 | |
| 104 | ;; - add support for ** to pcm. |
| 105 | ;; - Add vc-file-name-completion-table to read-file-name-internal. |
| 106 | ;; - A feature like completing-help.el. |
| 107 | |
| 108 | ;;; Code: |
| 109 | |
| 110 | (eval-when-compile (require 'cl)) |
| 111 | |
| 112 | ;;; Completion table manipulation |
| 113 | |
| 114 | ;; New completion-table operation. |
| 115 | (defun completion-boundaries (string table pred suffix) |
| 116 | "Return the boundaries of the completions returned by TABLE for STRING. |
| 117 | STRING is the string on which completion will be performed. |
| 118 | SUFFIX is the string after point. |
| 119 | The result is of the form (START . END) where START is the position |
| 120 | in STRING of the beginning of the completion field and END is the position |
| 121 | in SUFFIX of the end of the completion field. |
| 122 | E.g. for simple completion tables, the result is always (0 . (length SUFFIX)) |
| 123 | and for file names the result is the positions delimited by |
| 124 | the closest directory separators." |
| 125 | (let ((boundaries (if (functionp table) |
| 126 | (funcall table string pred (cons 'boundaries suffix))))) |
| 127 | (if (not (eq (car-safe boundaries) 'boundaries)) |
| 128 | (setq boundaries nil)) |
| 129 | (cons (or (cadr boundaries) 0) |
| 130 | (or (cddr boundaries) (length suffix))))) |
| 131 | |
| 132 | (defun completion--some (fun xs) |
| 133 | "Apply FUN to each element of XS in turn. |
| 134 | Return the first non-nil returned value. |
| 135 | Like CL's `some'." |
| 136 | (lexical-let ((firsterror nil) |
| 137 | res) |
| 138 | (while (and (not res) xs) |
| 139 | (condition-case err |
| 140 | (setq res (funcall fun (pop xs))) |
| 141 | (error (unless firsterror (setq firsterror err)) nil))) |
| 142 | (or res |
| 143 | (if firsterror (signal (car firsterror) (cdr firsterror)))))) |
| 144 | |
| 145 | (defun complete-with-action (action table string pred) |
| 146 | "Perform completion ACTION. |
| 147 | STRING is the string to complete. |
| 148 | TABLE is the completion table, which should not be a function. |
| 149 | PRED is a completion predicate. |
| 150 | ACTION can be one of nil, t or `lambda'." |
| 151 | (cond |
| 152 | ((functionp table) (funcall table string pred action)) |
| 153 | ((eq (car-safe action) 'boundaries) |
| 154 | (cons 'boundaries (completion-boundaries string table pred (cdr action)))) |
| 155 | (t |
| 156 | (funcall |
| 157 | (cond |
| 158 | ((null action) 'try-completion) |
| 159 | ((eq action t) 'all-completions) |
| 160 | (t 'test-completion)) |
| 161 | string table pred)))) |
| 162 | |
| 163 | (defun completion-table-dynamic (fun) |
| 164 | "Use function FUN as a dynamic completion table. |
| 165 | FUN is called with one argument, the string for which completion is required, |
| 166 | and it should return an alist containing all the intended possible completions. |
| 167 | This alist may be a full list of possible completions so that FUN can ignore |
| 168 | the value of its argument. If completion is performed in the minibuffer, |
| 169 | FUN will be called in the buffer from which the minibuffer was entered. |
| 170 | |
| 171 | The result of the `completion-table-dynamic' form is a function |
| 172 | that can be used as the COLLECTION argument to `try-completion' and |
| 173 | `all-completions'. See Info node `(elisp)Programmed Completion'." |
| 174 | (lexical-let ((fun fun)) |
| 175 | (lambda (string pred action) |
| 176 | (with-current-buffer (let ((win (minibuffer-selected-window))) |
| 177 | (if (window-live-p win) (window-buffer win) |
| 178 | (current-buffer))) |
| 179 | (complete-with-action action (funcall fun string) string pred))))) |
| 180 | |
| 181 | (defmacro lazy-completion-table (var fun) |
| 182 | "Initialize variable VAR as a lazy completion table. |
| 183 | If the completion table VAR is used for the first time (e.g., by passing VAR |
| 184 | as an argument to `try-completion'), the function FUN is called with no |
| 185 | arguments. FUN must return the completion table that will be stored in VAR. |
| 186 | If completion is requested in the minibuffer, FUN will be called in the buffer |
| 187 | from which the minibuffer was entered. The return value of |
| 188 | `lazy-completion-table' must be used to initialize the value of VAR. |
| 189 | |
| 190 | You should give VAR a non-nil `risky-local-variable' property." |
| 191 | (declare (debug (symbolp lambda-expr))) |
| 192 | (let ((str (make-symbol "string"))) |
| 193 | `(completion-table-dynamic |
| 194 | (lambda (,str) |
| 195 | (when (functionp ,var) |
| 196 | (setq ,var (,fun))) |
| 197 | ,var)))) |
| 198 | |
| 199 | (defun completion-table-case-fold (table string pred action) |
| 200 | (let ((completion-ignore-case t)) |
| 201 | (complete-with-action action table string pred))) |
| 202 | |
| 203 | (defun completion-table-with-context (prefix table string pred action) |
| 204 | ;; TODO: add `suffix' maybe? |
| 205 | ;; Notice that `pred' may not be a function in some abusive cases. |
| 206 | (when (functionp pred) |
| 207 | (setq pred |
| 208 | (lexical-let ((pred pred)) |
| 209 | ;; Predicates are called differently depending on the nature of |
| 210 | ;; the completion table :-( |
| 211 | (cond |
| 212 | ((vectorp table) ;Obarray. |
| 213 | (lambda (sym) (funcall pred (concat prefix (symbol-name sym))))) |
| 214 | ((hash-table-p table) |
| 215 | (lambda (s v) (funcall pred (concat prefix s)))) |
| 216 | ((functionp table) |
| 217 | (lambda (s) (funcall pred (concat prefix s)))) |
| 218 | (t ;Lists and alists. |
| 219 | (lambda (s) |
| 220 | (funcall pred (concat prefix (if (consp s) (car s) s))))))))) |
| 221 | (if (eq (car-safe action) 'boundaries) |
| 222 | (let* ((len (length prefix)) |
| 223 | (bound (completion-boundaries string table pred (cdr action)))) |
| 224 | (list* 'boundaries (+ (car bound) len) (cdr bound))) |
| 225 | (let ((comp (complete-with-action action table string pred))) |
| 226 | (cond |
| 227 | ;; In case of try-completion, add the prefix. |
| 228 | ((stringp comp) (concat prefix comp)) |
| 229 | (t comp))))) |
| 230 | |
| 231 | (defun completion-table-with-terminator (terminator table string pred action) |
| 232 | "Construct a completion table like TABLE but with an extra TERMINATOR. |
| 233 | This is meant to be called in a curried way by first passing TERMINATOR |
| 234 | and TABLE only (via `apply-partially'). |
| 235 | TABLE is a completion table, and TERMINATOR is a string appended to TABLE's |
| 236 | completion if it is complete. TERMINATOR is also used to determine the |
| 237 | completion suffix's boundary. |
| 238 | TERMINATOR can also be a cons cell (TERMINATOR . TERMINATOR-REGEXP) |
| 239 | in which case TERMINATOR-REGEXP is a regular expression whose submatch |
| 240 | number 1 should match TERMINATOR. This is used when there is a need to |
| 241 | distinguish occurrences of the TERMINATOR strings which are really terminators |
| 242 | from others (e.g. escaped)." |
| 243 | (cond |
| 244 | ((eq (car-safe action) 'boundaries) |
| 245 | (let* ((suffix (cdr action)) |
| 246 | (bounds (completion-boundaries string table pred suffix)) |
| 247 | (terminator-regexp (if (consp terminator) |
| 248 | (cdr terminator) (regexp-quote terminator))) |
| 249 | (max (string-match terminator-regexp suffix))) |
| 250 | (list* 'boundaries (car bounds) |
| 251 | (min (cdr bounds) (or max (length suffix)))))) |
| 252 | ((eq action nil) |
| 253 | (let ((comp (try-completion string table pred))) |
| 254 | (if (consp terminator) (setq terminator (car terminator))) |
| 255 | (if (eq comp t) |
| 256 | (concat string terminator) |
| 257 | (if (and (stringp comp) |
| 258 | ;; FIXME: Try to avoid this second call, especially since |
| 259 | ;; it may be very inefficient (because `comp' made us |
| 260 | ;; jump to a new boundary, so we complete in that |
| 261 | ;; boundary with an empty start string). |
| 262 | ;; completion-boundaries might help. |
| 263 | (eq (try-completion comp table pred) t)) |
| 264 | (concat comp terminator) |
| 265 | comp)))) |
| 266 | ((eq action t) |
| 267 | ;; FIXME: We generally want the `try' and `all' behaviors to be |
| 268 | ;; consistent so pcm can merge the `all' output to get the `try' output, |
| 269 | ;; but that sometimes clashes with the need for `all' output to look |
| 270 | ;; good in *Completions*. |
| 271 | ;; (mapcar (lambda (s) (concat s terminator)) |
| 272 | ;; (all-completions string table pred)))) |
| 273 | (all-completions string table pred)) |
| 274 | ;; completion-table-with-terminator is always used for |
| 275 | ;; "sub-completions" so it's only called if the terminator is missing, |
| 276 | ;; in which case `test-completion' should return nil. |
| 277 | ((eq action 'lambda) nil))) |
| 278 | |
| 279 | (defun completion-table-with-predicate (table pred1 strict string pred2 action) |
| 280 | "Make a completion table equivalent to TABLE but filtered through PRED1. |
| 281 | PRED1 is a function of one argument which returns non-nil if and only if the |
| 282 | argument is an element of TABLE which should be considered for completion. |
| 283 | STRING, PRED2, and ACTION are the usual arguments to completion tables, |
| 284 | as described in `try-completion', `all-completions', and `test-completion'. |
| 285 | If STRICT is t, the predicate always applies; if nil it only applies if |
| 286 | it does not reduce the set of possible completions to nothing. |
| 287 | Note: TABLE needs to be a proper completion table which obeys predicates." |
| 288 | (cond |
| 289 | ((and (not strict) (eq action 'lambda)) |
| 290 | ;; Ignore pred1 since it doesn't really have to apply anyway. |
| 291 | (test-completion string table pred2)) |
| 292 | (t |
| 293 | (or (complete-with-action action table string |
| 294 | (if (null pred2) pred1 |
| 295 | (lexical-let ((pred1 pred2) (pred2 pred2)) |
| 296 | (lambda (x) |
| 297 | ;; Call `pred1' first, so that `pred2' |
| 298 | ;; really can't tell that `x' is in table. |
| 299 | (if (funcall pred1 x) (funcall pred2 x)))))) |
| 300 | ;; If completion failed and we're not applying pred1 strictly, try |
| 301 | ;; again without pred1. |
| 302 | (and (not strict) |
| 303 | (complete-with-action action table string pred2)))))) |
| 304 | |
| 305 | (defun completion-table-in-turn (&rest tables) |
| 306 | "Create a completion table that tries each table in TABLES in turn." |
| 307 | ;; FIXME: the boundaries may come from TABLE1 even when the completion list |
| 308 | ;; is returned by TABLE2 (because TABLE1 returned an empty list). |
| 309 | (lexical-let ((tables tables)) |
| 310 | (lambda (string pred action) |
| 311 | (completion--some (lambda (table) |
| 312 | (complete-with-action action table string pred)) |
| 313 | tables)))) |
| 314 | |
| 315 | ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b)) |
| 316 | ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun)) |
| 317 | (define-obsolete-function-alias |
| 318 | 'complete-in-turn 'completion-table-in-turn "23.1") |
| 319 | (define-obsolete-function-alias |
| 320 | 'dynamic-completion-table 'completion-table-dynamic "23.1") |
| 321 | |
| 322 | ;;; Minibuffer completion |
| 323 | |
| 324 | (defgroup minibuffer nil |
| 325 | "Controlling the behavior of the minibuffer." |
| 326 | :link '(custom-manual "(emacs)Minibuffer") |
| 327 | :group 'environment) |
| 328 | |
| 329 | (defun minibuffer-message (message &rest args) |
| 330 | "Temporarily display MESSAGE at the end of the minibuffer. |
| 331 | The text is displayed for `minibuffer-message-timeout' seconds, |
| 332 | or until the next input event arrives, whichever comes first. |
| 333 | Enclose MESSAGE in [...] if this is not yet the case. |
| 334 | If ARGS are provided, then pass MESSAGE through `format'." |
| 335 | (if (not (minibufferp (current-buffer))) |
| 336 | (progn |
| 337 | (if args |
| 338 | (apply 'message message args) |
| 339 | (message "%s" message)) |
| 340 | (prog1 (sit-for (or minibuffer-message-timeout 1000000)) |
| 341 | (message nil))) |
| 342 | ;; Clear out any old echo-area message to make way for our new thing. |
| 343 | (message nil) |
| 344 | (setq message (if (and (null args) (string-match-p "\\` *\\[.+\\]\\'" message)) |
| 345 | ;; Make sure we can put-text-property. |
| 346 | (copy-sequence message) |
| 347 | (concat " [" message "]"))) |
| 348 | (when args (setq message (apply 'format message args))) |
| 349 | (let ((ol (make-overlay (point-max) (point-max) nil t t)) |
| 350 | ;; A quit during sit-for normally only interrupts the sit-for, |
| 351 | ;; but since minibuffer-message is used at the end of a command, |
| 352 | ;; at a time when the command has virtually finished already, a C-g |
| 353 | ;; should really cause an abort-recursive-edit instead (i.e. as if |
| 354 | ;; the C-g had been typed at top-level). Binding inhibit-quit here |
| 355 | ;; is an attempt to get that behavior. |
| 356 | (inhibit-quit t)) |
| 357 | (unwind-protect |
| 358 | (progn |
| 359 | (unless (zerop (length message)) |
| 360 | ;; The current C cursor code doesn't know to use the overlay's |
| 361 | ;; marker's stickiness to figure out whether to place the cursor |
| 362 | ;; before or after the string, so let's spoon-feed it the pos. |
| 363 | (put-text-property 0 1 'cursor t message)) |
| 364 | (overlay-put ol 'after-string message) |
| 365 | (sit-for (or minibuffer-message-timeout 1000000))) |
| 366 | (delete-overlay ol))))) |
| 367 | |
| 368 | (defun minibuffer-completion-contents () |
| 369 | "Return the user input in a minibuffer before point as a string. |
| 370 | That is what completion commands operate on." |
| 371 | (buffer-substring (field-beginning) (point))) |
| 372 | |
| 373 | (defun delete-minibuffer-contents () |
| 374 | "Delete all user input in a minibuffer. |
| 375 | If the current buffer is not a minibuffer, erase its entire contents." |
| 376 | ;; We used to do `delete-field' here, but when file name shadowing |
| 377 | ;; is on, the field doesn't cover the entire minibuffer contents. |
| 378 | (delete-region (minibuffer-prompt-end) (point-max))) |
| 379 | |
| 380 | (defcustom completion-auto-help t |
| 381 | "Non-nil means automatically provide help for invalid completion input. |
| 382 | If the value is t the *Completion* buffer is displayed whenever completion |
| 383 | is requested but cannot be done. |
| 384 | If the value is `lazy', the *Completions* buffer is only displayed after |
| 385 | the second failed attempt to complete." |
| 386 | :type '(choice (const nil) (const t) (const lazy)) |
| 387 | :group 'minibuffer) |
| 388 | |
| 389 | (defconst completion-styles-alist |
| 390 | '((emacs21 |
| 391 | completion-emacs21-try-completion completion-emacs21-all-completions |
| 392 | "Simple prefix-based completion. |
| 393 | I.e. when completing \"foo_bar\" (where _ is the position of point), |
| 394 | it will consider all completions candidates matching the glob |
| 395 | pattern \"foobar*\".") |
| 396 | (emacs22 |
| 397 | completion-emacs22-try-completion completion-emacs22-all-completions |
| 398 | "Prefix completion that only operates on the text before point. |
| 399 | I.e. when completing \"foo_bar\" (where _ is the position of point), |
| 400 | it will consider all completions candidates matching the glob |
| 401 | pattern \"foo*\" and will add back \"bar\" to the end of it.") |
| 402 | (basic |
| 403 | completion-basic-try-completion completion-basic-all-completions |
| 404 | "Completion of the prefix before point and the suffix after point. |
| 405 | I.e. when completing \"foo_bar\" (where _ is the position of point), |
| 406 | it will consider all completions candidates matching the glob |
| 407 | pattern \"foo*bar*\".") |
| 408 | (partial-completion |
| 409 | completion-pcm-try-completion completion-pcm-all-completions |
| 410 | "Completion of multiple words, each one taken as a prefix. |
| 411 | I.e. when completing \"l-co_h\" (where _ is the position of point), |
| 412 | it will consider all completions candidates matching the glob |
| 413 | pattern \"l*-co*h*\". |
| 414 | Furthermore, for completions that are done step by step in subfields, |
| 415 | the method is applied to all the preceding fields that do not yet match. |
| 416 | E.g. C-x C-f /u/mo/s TAB could complete to /usr/monnier/src. |
| 417 | Additionally the user can use the char \"*\" as a glob pattern.") |
| 418 | (substring |
| 419 | completion-substring-try-completion completion-substring-all-completions |
| 420 | "Completion of the string taken as a substring. |
| 421 | I.e. when completing \"foo_bar\" (where _ is the position of point), |
| 422 | it will consider all completions candidates matching the glob |
| 423 | pattern \"*foo*bar*\".") |
| 424 | (initials |
| 425 | completion-initials-try-completion completion-initials-all-completions |
| 426 | "Completion of acronyms and initialisms. |
| 427 | E.g. can complete M-x lch to list-command-history |
| 428 | and C-x C-f ~/sew to ~/src/emacs/work.")) |
| 429 | "List of available completion styles. |
| 430 | Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS DOC): |
| 431 | where NAME is the name that should be used in `completion-styles', |
| 432 | TRY-COMPLETION is the function that does the completion (it should |
| 433 | follow the same calling convention as `completion-try-completion'), |
| 434 | ALL-COMPLETIONS is the function that lists the completions (it should |
| 435 | follow the calling convention of `completion-all-completions'), |
| 436 | and DOC describes the way this style of completion works.") |
| 437 | |
| 438 | (defcustom completion-styles |
| 439 | ;; First, use `basic' because prefix completion has been the standard |
| 440 | ;; for "ever" and works well in most cases, so using it first |
| 441 | ;; ensures that we obey previous behavior in most cases. |
| 442 | '(basic |
| 443 | ;; Then use `partial-completion' because it has proven to |
| 444 | ;; be a very convenient extension. |
| 445 | partial-completion |
| 446 | ;; Finally use `emacs22' so as to maintain (in many/most cases) |
| 447 | ;; the previous behavior that when completing "foobar" with point |
| 448 | ;; between "foo" and "bar" the completion try to complete "foo" |
| 449 | ;; and simply add "bar" to the end of the result. |
| 450 | emacs22) |
| 451 | "List of completion styles to use. |
| 452 | The available styles are listed in `completion-styles-alist'." |
| 453 | :type `(repeat (choice ,@(mapcar (lambda (x) (list 'const (car x))) |
| 454 | completion-styles-alist))) |
| 455 | :group 'minibuffer |
| 456 | :version "23.1") |
| 457 | |
| 458 | (defun completion-try-completion (string table pred point) |
| 459 | "Try to complete STRING using completion table TABLE. |
| 460 | Only the elements of table that satisfy predicate PRED are considered. |
| 461 | POINT is the position of point within STRING. |
| 462 | The return value can be either nil to indicate that there is no completion, |
| 463 | t to indicate that STRING is the only possible completion, |
| 464 | or a pair (STRING . NEWPOINT) of the completed result string together with |
| 465 | a new position for point." |
| 466 | (completion--some (lambda (style) |
| 467 | (funcall (nth 1 (assq style completion-styles-alist)) |
| 468 | string table pred point)) |
| 469 | completion-styles)) |
| 470 | |
| 471 | (defun completion-all-completions (string table pred point) |
| 472 | "List the possible completions of STRING in completion table TABLE. |
| 473 | Only the elements of table that satisfy predicate PRED are considered. |
| 474 | POINT is the position of point within STRING. |
| 475 | The return value is a list of completions and may contain the base-size |
| 476 | in the last `cdr'." |
| 477 | ;; FIXME: We need to additionally return the info needed for the |
| 478 | ;; second part of completion-base-position. |
| 479 | (completion--some (lambda (style) |
| 480 | (funcall (nth 2 (assq style completion-styles-alist)) |
| 481 | string table pred point)) |
| 482 | completion-styles)) |
| 483 | |
| 484 | (defun minibuffer--bitset (modified completions exact) |
| 485 | (logior (if modified 4 0) |
| 486 | (if completions 2 0) |
| 487 | (if exact 1 0))) |
| 488 | |
| 489 | (defun completion--replace (beg end newtext) |
| 490 | "Replace the buffer text between BEG and END with NEWTEXT. |
| 491 | Moves point to the end of the new text." |
| 492 | ;; Maybe this should be in subr.el. |
| 493 | ;; You'd think this is trivial to do, but details matter if you want |
| 494 | ;; to keep markers "at the right place" and be robust in the face of |
| 495 | ;; after-change-functions that may themselves modify the buffer. |
| 496 | (let ((prefix-len 0)) |
| 497 | ;; Don't touch markers in the shared prefix (if any). |
| 498 | (while (and (< prefix-len (length newtext)) |
| 499 | (< (+ beg prefix-len) end) |
| 500 | (eq (char-after (+ beg prefix-len)) |
| 501 | (aref newtext prefix-len))) |
| 502 | (setq prefix-len (1+ prefix-len))) |
| 503 | (unless (zerop prefix-len) |
| 504 | (setq beg (+ beg prefix-len)) |
| 505 | (setq newtext (substring newtext prefix-len)))) |
| 506 | (let ((suffix-len 0)) |
| 507 | ;; Don't touch markers in the shared suffix (if any). |
| 508 | (while (and (< suffix-len (length newtext)) |
| 509 | (< beg (- end suffix-len)) |
| 510 | (eq (char-before (- end suffix-len)) |
| 511 | (aref newtext (- (length newtext) suffix-len 1)))) |
| 512 | (setq suffix-len (1+ suffix-len))) |
| 513 | (unless (zerop suffix-len) |
| 514 | (setq end (- end suffix-len)) |
| 515 | (setq newtext (substring newtext 0 (- suffix-len)))) |
| 516 | (goto-char beg) |
| 517 | (insert newtext) |
| 518 | (delete-region (point) (+ (point) (- end beg))) |
| 519 | (forward-char suffix-len))) |
| 520 | |
| 521 | (defcustom completion-cycle-threshold nil |
| 522 | "Number of completion candidates below which cycling is used. |
| 523 | Depending on this setting `minibuffer-complete' may use cycling, |
| 524 | like `minibuffer-force-complete'. |
| 525 | If nil, cycling is never used. |
| 526 | If t, cycling is always used. |
| 527 | If an integer, cycling is used as soon as there are fewer completion |
| 528 | candidates than this number." |
| 529 | :type '(choice (const :tag "No cycling" nil) |
| 530 | (const :tag "Always cycle" t) |
| 531 | (integer :tag "Threshold"))) |
| 532 | |
| 533 | (defvar completion-all-sorted-completions nil) |
| 534 | (make-variable-buffer-local 'completion-all-sorted-completions) |
| 535 | (defvar completion-cycling nil) |
| 536 | |
| 537 | (defvar completion-fail-discreetly nil |
| 538 | "If non-nil, stay quiet when there is no match.") |
| 539 | |
| 540 | (defun completion--do-completion (&optional try-completion-function) |
| 541 | "Do the completion and return a summary of what happened. |
| 542 | M = completion was performed, the text was Modified. |
| 543 | C = there were available Completions. |
| 544 | E = after completion we now have an Exact match. |
| 545 | |
| 546 | MCE |
| 547 | 000 0 no possible completion |
| 548 | 001 1 was already an exact and unique completion |
| 549 | 010 2 no completion happened |
| 550 | 011 3 was already an exact completion |
| 551 | 100 4 ??? impossible |
| 552 | 101 5 ??? impossible |
| 553 | 110 6 some completion happened |
| 554 | 111 7 completed to an exact completion" |
| 555 | (lexical-let* |
| 556 | ((beg (field-beginning)) |
| 557 | (end (field-end)) |
| 558 | (string (buffer-substring beg end)) |
| 559 | (comp (funcall (or try-completion-function |
| 560 | 'completion-try-completion) |
| 561 | string |
| 562 | minibuffer-completion-table |
| 563 | minibuffer-completion-predicate |
| 564 | (- (point) beg)))) |
| 565 | (cond |
| 566 | ((null comp) |
| 567 | (minibuffer-hide-completions) |
| 568 | (unless completion-fail-discreetly |
| 569 | (ding) (minibuffer-message "No match")) |
| 570 | (minibuffer--bitset nil nil nil)) |
| 571 | ((eq t comp) |
| 572 | (minibuffer-hide-completions) |
| 573 | (goto-char (field-end)) |
| 574 | (minibuffer--bitset nil nil t)) ;Exact and unique match. |
| 575 | (t |
| 576 | ;; `completed' should be t if some completion was done, which doesn't |
| 577 | ;; include simply changing the case of the entered string. However, |
| 578 | ;; for appearance, the string is rewritten if the case changes. |
| 579 | (lexical-let* |
| 580 | ((comp-pos (cdr comp)) |
| 581 | (completion (car comp)) |
| 582 | (completed (not (eq t (compare-strings completion nil nil |
| 583 | string nil nil t)))) |
| 584 | (unchanged (eq t (compare-strings completion nil nil |
| 585 | string nil nil nil)))) |
| 586 | (if unchanged |
| 587 | (goto-char end) |
| 588 | ;; Insert in minibuffer the chars we got. |
| 589 | (completion--replace beg end completion)) |
| 590 | ;; Move point to its completion-mandated destination. |
| 591 | (forward-char (- comp-pos (length completion))) |
| 592 | |
| 593 | (if (not (or unchanged completed)) |
| 594 | ;; The case of the string changed, but that's all. We're not sure |
| 595 | ;; whether this is a unique completion or not, so try again using |
| 596 | ;; the real case (this shouldn't recurse again, because the next |
| 597 | ;; time try-completion will return either t or the exact string). |
| 598 | (completion--do-completion try-completion-function) |
| 599 | |
| 600 | ;; It did find a match. Do we match some possibility exactly now? |
| 601 | (let ((exact (test-completion completion |
| 602 | minibuffer-completion-table |
| 603 | minibuffer-completion-predicate)) |
| 604 | (comps |
| 605 | ;; Check to see if we want to do cycling. We do it |
| 606 | ;; here, after having performed the normal completion, |
| 607 | ;; so as to take advantage of the difference between |
| 608 | ;; try-completion and all-completions, for things |
| 609 | ;; like completion-ignored-extensions. |
| 610 | (when (and completion-cycle-threshold |
| 611 | ;; Check that the completion didn't make |
| 612 | ;; us jump to a different boundary. |
| 613 | (or (not completed) |
| 614 | (< (car (completion-boundaries |
| 615 | (substring completion 0 comp-pos) |
| 616 | minibuffer-completion-table |
| 617 | minibuffer-completion-predicate |
| 618 | "")) |
| 619 | comp-pos))) |
| 620 | (completion-all-sorted-completions)))) |
| 621 | (completion--flush-all-sorted-completions) |
| 622 | (cond |
| 623 | ((and (consp (cdr comps)) ;; There's something to cycle. |
| 624 | (not (ignore-errors |
| 625 | ;; This signal an (intended) error if comps is too |
| 626 | ;; short or if completion-cycle-threshold is t. |
| 627 | (consp (nthcdr completion-cycle-threshold comps))))) |
| 628 | ;; Fewer than completion-cycle-threshold remaining |
| 629 | ;; completions: let's cycle. |
| 630 | (setq completed t exact t) |
| 631 | (setq completion-all-sorted-completions comps) |
| 632 | (minibuffer-force-complete)) |
| 633 | (completed |
| 634 | ;; We could also decide to refresh the completions, |
| 635 | ;; if they're displayed (and assuming there are |
| 636 | ;; completions left). |
| 637 | (minibuffer-hide-completions)) |
| 638 | ;; Show the completion table, if requested. |
| 639 | ((not exact) |
| 640 | (if (case completion-auto-help |
| 641 | (lazy (eq this-command last-command)) |
| 642 | (t completion-auto-help)) |
| 643 | (minibuffer-completion-help) |
| 644 | (minibuffer-message "Next char not unique"))) |
| 645 | ;; If the last exact completion and this one were the same, it |
| 646 | ;; means we've already given a "Next char not unique" message |
| 647 | ;; and the user's hit TAB again, so now we give him help. |
| 648 | ((eq this-command last-command) |
| 649 | (if completion-auto-help (minibuffer-completion-help)))) |
| 650 | |
| 651 | (minibuffer--bitset completed t exact)))))))) |
| 652 | |
| 653 | (defun minibuffer-complete () |
| 654 | "Complete the minibuffer contents as far as possible. |
| 655 | Return nil if there is no valid completion, else t. |
| 656 | If no characters can be completed, display a list of possible completions. |
| 657 | If you repeat this command after it displayed such a list, |
| 658 | scroll the window of possible completions." |
| 659 | (interactive) |
| 660 | ;; If the previous command was not this, |
| 661 | ;; mark the completion buffer obsolete. |
| 662 | (unless (eq this-command last-command) |
| 663 | (completion--flush-all-sorted-completions) |
| 664 | (setq minibuffer-scroll-window nil)) |
| 665 | |
| 666 | (cond |
| 667 | ;; If there's a fresh completion window with a live buffer, |
| 668 | ;; and this command is repeated, scroll that window. |
| 669 | ((window-live-p minibuffer-scroll-window) |
| 670 | (let ((window minibuffer-scroll-window)) |
| 671 | (with-current-buffer (window-buffer window) |
| 672 | (if (pos-visible-in-window-p (point-max) window) |
| 673 | ;; If end is in view, scroll up to the beginning. |
| 674 | (set-window-start window (point-min) nil) |
| 675 | ;; Else scroll down one screen. |
| 676 | (scroll-other-window)) |
| 677 | nil))) |
| 678 | ;; If we're cycling, keep on cycling. |
| 679 | ((and completion-cycling completion-all-sorted-completions) |
| 680 | (minibuffer-force-complete) |
| 681 | t) |
| 682 | (t (case (completion--do-completion) |
| 683 | (#b000 nil) |
| 684 | (#b001 (minibuffer-message "Sole completion") |
| 685 | t) |
| 686 | (#b011 (minibuffer-message "Complete, but not unique") |
| 687 | t) |
| 688 | (t t))))) |
| 689 | |
| 690 | (defun completion--flush-all-sorted-completions (&rest ignore) |
| 691 | (setq completion-cycling nil) |
| 692 | (setq completion-all-sorted-completions nil)) |
| 693 | |
| 694 | (defun completion-all-sorted-completions () |
| 695 | (or completion-all-sorted-completions |
| 696 | (let* ((start (field-beginning)) |
| 697 | (end (field-end)) |
| 698 | (all (completion-all-completions (buffer-substring start end) |
| 699 | minibuffer-completion-table |
| 700 | minibuffer-completion-predicate |
| 701 | (- (point) start))) |
| 702 | (last (last all)) |
| 703 | (base-size (or (cdr last) 0))) |
| 704 | (when last |
| 705 | (setcdr last nil) |
| 706 | ;; Prefer shorter completions. |
| 707 | (setq all (sort all (lambda (c1 c2) (< (length c1) (length c2))))) |
| 708 | ;; Prefer recently used completions. |
| 709 | (let ((hist (symbol-value minibuffer-history-variable))) |
| 710 | (setq all (sort all (lambda (c1 c2) |
| 711 | (> (length (member c1 hist)) |
| 712 | (length (member c2 hist))))))) |
| 713 | ;; Cache the result. This is not just for speed, but also so that |
| 714 | ;; repeated calls to minibuffer-force-complete can cycle through |
| 715 | ;; all possibilities. |
| 716 | (add-hook 'after-change-functions |
| 717 | 'completion--flush-all-sorted-completions nil t) |
| 718 | (setq completion-all-sorted-completions |
| 719 | (nconc all base-size)))))) |
| 720 | |
| 721 | (defun minibuffer-force-complete () |
| 722 | "Complete the minibuffer to an exact match. |
| 723 | Repeated uses step through the possible completions." |
| 724 | (interactive) |
| 725 | ;; FIXME: Need to deal with the extra-size issue here as well. |
| 726 | ;; FIXME: ~/src/emacs/t<M-TAB>/lisp/minibuffer.el completes to |
| 727 | ;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el. |
| 728 | (let* ((start (field-beginning)) |
| 729 | (end (field-end)) |
| 730 | (all (completion-all-sorted-completions))) |
| 731 | (if (not (consp all)) |
| 732 | (minibuffer-message (if all "No more completions" "No completions")) |
| 733 | (setq completion-cycling t) |
| 734 | (goto-char end) |
| 735 | (insert (car all)) |
| 736 | (delete-region (+ start (cdr (last all))) end) |
| 737 | ;; If completing file names, (car all) may be a directory, so we'd now |
| 738 | ;; have a new set of possible completions and might want to reset |
| 739 | ;; completion-all-sorted-completions to nil, but we prefer not to, |
| 740 | ;; so that repeated calls minibuffer-force-complete still cycle |
| 741 | ;; through the previous possible completions. |
| 742 | (let ((last (last all))) |
| 743 | (setcdr last (cons (car all) (cdr last))) |
| 744 | (setq completion-all-sorted-completions (cdr all)))))) |
| 745 | |
| 746 | (defvar minibuffer-confirm-exit-commands |
| 747 | '(minibuffer-complete minibuffer-complete-word PC-complete PC-complete-word) |
| 748 | "A list of commands which cause an immediately following |
| 749 | `minibuffer-complete-and-exit' to ask for extra confirmation.") |
| 750 | |
| 751 | (defun minibuffer-complete-and-exit () |
| 752 | "Exit if the minibuffer contains a valid completion. |
| 753 | Otherwise, try to complete the minibuffer contents. If |
| 754 | completion leads to a valid completion, a repetition of this |
| 755 | command will exit. |
| 756 | |
| 757 | If `minibuffer-completion-confirm' is `confirm', do not try to |
| 758 | complete; instead, ask for confirmation and accept any input if |
| 759 | confirmed. |
| 760 | If `minibuffer-completion-confirm' is `confirm-after-completion', |
| 761 | do not try to complete; instead, ask for confirmation if the |
| 762 | preceding minibuffer command was a member of |
| 763 | `minibuffer-confirm-exit-commands', and accept the input |
| 764 | otherwise." |
| 765 | (interactive) |
| 766 | (lexical-let ((beg (field-beginning)) |
| 767 | (end (field-end))) |
| 768 | (cond |
| 769 | ;; Allow user to specify null string |
| 770 | ((= beg end) (exit-minibuffer)) |
| 771 | ((test-completion (buffer-substring beg end) |
| 772 | minibuffer-completion-table |
| 773 | minibuffer-completion-predicate) |
| 774 | ;; FIXME: completion-ignore-case has various slightly |
| 775 | ;; incompatible meanings. E.g. it can reflect whether the user |
| 776 | ;; wants completion to pay attention to case, or whether the |
| 777 | ;; string will be used in a context where case is significant. |
| 778 | ;; E.g. usually try-completion should obey the first, whereas |
| 779 | ;; test-completion should obey the second. |
| 780 | (when completion-ignore-case |
| 781 | ;; Fixup case of the field, if necessary. |
| 782 | (let* ((string (buffer-substring beg end)) |
| 783 | (compl (try-completion |
| 784 | string |
| 785 | minibuffer-completion-table |
| 786 | minibuffer-completion-predicate))) |
| 787 | (when (and (stringp compl) (not (equal string compl)) |
| 788 | ;; If it weren't for this piece of paranoia, I'd replace |
| 789 | ;; the whole thing with a call to do-completion. |
| 790 | ;; This is important, e.g. when the current minibuffer's |
| 791 | ;; content is a directory which only contains a single |
| 792 | ;; file, so `try-completion' actually completes to |
| 793 | ;; that file. |
| 794 | (= (length string) (length compl))) |
| 795 | (goto-char end) |
| 796 | (insert compl) |
| 797 | (delete-region beg end)))) |
| 798 | (exit-minibuffer)) |
| 799 | |
| 800 | ((memq minibuffer-completion-confirm '(confirm confirm-after-completion)) |
| 801 | ;; The user is permitted to exit with an input that's rejected |
| 802 | ;; by test-completion, after confirming her choice. |
| 803 | (if (or (eq last-command this-command) |
| 804 | ;; For `confirm-after-completion' we only ask for confirmation |
| 805 | ;; if trying to exit immediately after typing TAB (this |
| 806 | ;; catches most minibuffer typos). |
| 807 | (and (eq minibuffer-completion-confirm 'confirm-after-completion) |
| 808 | (not (memq last-command minibuffer-confirm-exit-commands)))) |
| 809 | (exit-minibuffer) |
| 810 | (minibuffer-message "Confirm") |
| 811 | nil)) |
| 812 | |
| 813 | (t |
| 814 | ;; Call do-completion, but ignore errors. |
| 815 | (case (condition-case nil |
| 816 | (completion--do-completion) |
| 817 | (error 1)) |
| 818 | ((#b001 #b011) (exit-minibuffer)) |
| 819 | (#b111 (if (not minibuffer-completion-confirm) |
| 820 | (exit-minibuffer) |
| 821 | (minibuffer-message "Confirm") |
| 822 | nil)) |
| 823 | (t nil)))))) |
| 824 | |
| 825 | (defun completion--try-word-completion (string table predicate point) |
| 826 | (let ((comp (completion-try-completion string table predicate point))) |
| 827 | (if (not (consp comp)) |
| 828 | comp |
| 829 | |
| 830 | ;; If completion finds next char not unique, |
| 831 | ;; consider adding a space or a hyphen. |
| 832 | (when (= (length string) (length (car comp))) |
| 833 | ;; Mark the added char with the `completion-word' property, so it |
| 834 | ;; can be handled specially by completion styles such as |
| 835 | ;; partial-completion. |
| 836 | ;; We used to remove `partial-completion' from completion-styles |
| 837 | ;; instead, but it was too blunt, leading to situations where SPC |
| 838 | ;; was the only insertable char at point but minibuffer-complete-word |
| 839 | ;; refused inserting it. |
| 840 | (let ((exts (mapcar (lambda (str) (propertize str 'completion-try-word t)) |
| 841 | '(" " "-"))) |
| 842 | (before (substring string 0 point)) |
| 843 | (after (substring string point)) |
| 844 | tem) |
| 845 | (while (and exts (not (consp tem))) |
| 846 | (setq tem (completion-try-completion |
| 847 | (concat before (pop exts) after) |
| 848 | table predicate (1+ point)))) |
| 849 | (if (consp tem) (setq comp tem)))) |
| 850 | |
| 851 | ;; Completing a single word is actually more difficult than completing |
| 852 | ;; as much as possible, because we first have to find the "current |
| 853 | ;; position" in `completion' in order to find the end of the word |
| 854 | ;; we're completing. Normally, `string' is a prefix of `completion', |
| 855 | ;; which makes it trivial to find the position, but with fancier |
| 856 | ;; completion (plus env-var expansion, ...) `completion' might not |
| 857 | ;; look anything like `string' at all. |
| 858 | (let* ((comppoint (cdr comp)) |
| 859 | (completion (car comp)) |
| 860 | (before (substring string 0 point)) |
| 861 | (combined (concat before "\n" completion))) |
| 862 | ;; Find in completion the longest text that was right before point. |
| 863 | (when (string-match "\\(.+\\)\n.*?\\1" combined) |
| 864 | (let* ((prefix (match-string 1 before)) |
| 865 | ;; We used non-greedy match to make `rem' as long as possible. |
| 866 | (rem (substring combined (match-end 0))) |
| 867 | ;; Find in the remainder of completion the longest text |
| 868 | ;; that was right after point. |
| 869 | (after (substring string point)) |
| 870 | (suffix (if (string-match "\\`\\(.+\\).*\n.*\\1" |
| 871 | (concat after "\n" rem)) |
| 872 | (match-string 1 after)))) |
| 873 | ;; The general idea is to try and guess what text was inserted |
| 874 | ;; at point by the completion. Problem is: if we guess wrong, |
| 875 | ;; we may end up treating as "added by completion" text that was |
| 876 | ;; actually painfully typed by the user. So if we then cut |
| 877 | ;; after the first word, we may throw away things the |
| 878 | ;; user wrote. So let's try to be as conservative as possible: |
| 879 | ;; only cut after the first word, if we're reasonably sure that |
| 880 | ;; our guess is correct. |
| 881 | ;; Note: a quick survey on emacs-devel seemed to indicate that |
| 882 | ;; nobody actually cares about the "word-at-a-time" feature of |
| 883 | ;; minibuffer-complete-word, whose real raison-d'être is that it |
| 884 | ;; tries to add "-" or " ". One more reason to only cut after |
| 885 | ;; the first word, if we're really sure we're right. |
| 886 | (when (and (or suffix (zerop (length after))) |
| 887 | (string-match (concat |
| 888 | ;; Make submatch 1 as small as possible |
| 889 | ;; to reduce the risk of cutting |
| 890 | ;; valuable text. |
| 891 | ".*" (regexp-quote prefix) "\\(.*?\\)" |
| 892 | (if suffix (regexp-quote suffix) "\\'")) |
| 893 | completion) |
| 894 | ;; The new point in `completion' should also be just |
| 895 | ;; before the suffix, otherwise something more complex |
| 896 | ;; is going on, and we're not sure where we are. |
| 897 | (eq (match-end 1) comppoint) |
| 898 | ;; (match-beginning 1)..comppoint is now the stretch |
| 899 | ;; of text in `completion' that was completed at point. |
| 900 | (string-match "\\W" completion (match-beginning 1)) |
| 901 | ;; Is there really something to cut? |
| 902 | (> comppoint (match-end 0))) |
| 903 | ;; Cut after the first word. |
| 904 | (let ((cutpos (match-end 0))) |
| 905 | (setq completion (concat (substring completion 0 cutpos) |
| 906 | (substring completion comppoint))) |
| 907 | (setq comppoint cutpos))))) |
| 908 | |
| 909 | (cons completion comppoint))))) |
| 910 | |
| 911 | |
| 912 | (defun minibuffer-complete-word () |
| 913 | "Complete the minibuffer contents at most a single word. |
| 914 | After one word is completed as much as possible, a space or hyphen |
| 915 | is added, provided that matches some possible completion. |
| 916 | Return nil if there is no valid completion, else t." |
| 917 | (interactive) |
| 918 | (case (completion--do-completion 'completion--try-word-completion) |
| 919 | (#b000 nil) |
| 920 | (#b001 (minibuffer-message "Sole completion") |
| 921 | t) |
| 922 | (#b011 (minibuffer-message "Complete, but not unique") |
| 923 | t) |
| 924 | (t t))) |
| 925 | |
| 926 | (defface completions-annotations '((t :inherit italic)) |
| 927 | "Face to use for annotations in the *Completions* buffer.") |
| 928 | |
| 929 | (defcustom completions-format 'horizontal |
| 930 | "Define the appearance and sorting of completions. |
| 931 | If the value is `vertical', display completions sorted vertically |
| 932 | in columns in the *Completions* buffer. |
| 933 | If the value is `horizontal', display completions sorted |
| 934 | horizontally in alphabetical order, rather than down the screen." |
| 935 | :type '(choice (const horizontal) (const vertical)) |
| 936 | :group 'minibuffer |
| 937 | :version "23.2") |
| 938 | |
| 939 | (defun completion--insert-strings (strings) |
| 940 | "Insert a list of STRINGS into the current buffer. |
| 941 | Uses columns to keep the listing readable but compact. |
| 942 | It also eliminates runs of equal strings." |
| 943 | (when (consp strings) |
| 944 | (let* ((length (apply 'max |
| 945 | (mapcar (lambda (s) |
| 946 | (if (consp s) |
| 947 | (+ (string-width (car s)) |
| 948 | (string-width (cadr s))) |
| 949 | (string-width s))) |
| 950 | strings))) |
| 951 | (window (get-buffer-window (current-buffer) 0)) |
| 952 | (wwidth (if window (1- (window-width window)) 79)) |
| 953 | (columns (min |
| 954 | ;; At least 2 columns; at least 2 spaces between columns. |
| 955 | (max 2 (/ wwidth (+ 2 length))) |
| 956 | ;; Don't allocate more columns than we can fill. |
| 957 | ;; Windows can't show less than 3 lines anyway. |
| 958 | (max 1 (/ (length strings) 2)))) |
| 959 | (colwidth (/ wwidth columns)) |
| 960 | (column 0) |
| 961 | (rows (/ (length strings) columns)) |
| 962 | (row 0) |
| 963 | (laststring nil)) |
| 964 | ;; The insertion should be "sensible" no matter what choices were made |
| 965 | ;; for the parameters above. |
| 966 | (dolist (str strings) |
| 967 | (unless (equal laststring str) ; Remove (consecutive) duplicates. |
| 968 | (setq laststring str) |
| 969 | (let ((length (if (consp str) |
| 970 | (+ (string-width (car str)) |
| 971 | (string-width (cadr str))) |
| 972 | (string-width str)))) |
| 973 | (cond |
| 974 | ((eq completions-format 'vertical) |
| 975 | ;; Vertical format |
| 976 | (when (> row rows) |
| 977 | (forward-line (- -1 rows)) |
| 978 | (setq row 0 column (+ column colwidth))) |
| 979 | (when (> column 0) |
| 980 | (end-of-line) |
| 981 | (while (> (current-column) column) |
| 982 | (if (eobp) |
| 983 | (insert "\n") |
| 984 | (forward-line 1) |
| 985 | (end-of-line))) |
| 986 | (insert " \t") |
| 987 | (set-text-properties (- (point) 1) (point) |
| 988 | `(display (space :align-to ,column))))) |
| 989 | (t |
| 990 | ;; Horizontal format |
| 991 | (unless (bolp) |
| 992 | (if (< wwidth (+ (max colwidth length) column)) |
| 993 | ;; No space for `str' at point, move to next line. |
| 994 | (progn (insert "\n") (setq column 0)) |
| 995 | (insert " \t") |
| 996 | ;; Leave the space unpropertized so that in the case we're |
| 997 | ;; already past the goal column, there is still |
| 998 | ;; a space displayed. |
| 999 | (set-text-properties (- (point) 1) (point) |
| 1000 | ;; We can't just set tab-width, because |
| 1001 | ;; completion-setup-function will kill all |
| 1002 | ;; local variables :-( |
| 1003 | `(display (space :align-to ,column))) |
| 1004 | nil)))) |
| 1005 | (if (not (consp str)) |
| 1006 | (put-text-property (point) (progn (insert str) (point)) |
| 1007 | 'mouse-face 'highlight) |
| 1008 | (put-text-property (point) (progn (insert (car str)) (point)) |
| 1009 | 'mouse-face 'highlight) |
| 1010 | (add-text-properties (point) (progn (insert (cadr str)) (point)) |
| 1011 | '(mouse-face nil |
| 1012 | face completions-annotations))) |
| 1013 | (cond |
| 1014 | ((eq completions-format 'vertical) |
| 1015 | ;; Vertical format |
| 1016 | (if (> column 0) |
| 1017 | (forward-line) |
| 1018 | (insert "\n")) |
| 1019 | (setq row (1+ row))) |
| 1020 | (t |
| 1021 | ;; Horizontal format |
| 1022 | ;; Next column to align to. |
| 1023 | (setq column (+ column |
| 1024 | ;; Round up to a whole number of columns. |
| 1025 | (* colwidth (ceiling length colwidth)))))))))))) |
| 1026 | |
| 1027 | (defvar completion-common-substring nil) |
| 1028 | (make-obsolete-variable 'completion-common-substring nil "23.1") |
| 1029 | |
| 1030 | (defvar completion-setup-hook nil |
| 1031 | "Normal hook run at the end of setting up a completion list buffer. |
| 1032 | When this hook is run, the current buffer is the one in which the |
| 1033 | command to display the completion list buffer was run. |
| 1034 | The completion list buffer is available as the value of `standard-output'. |
| 1035 | See also `display-completion-list'.") |
| 1036 | |
| 1037 | (defface completions-first-difference |
| 1038 | '((t (:inherit bold))) |
| 1039 | "Face put on the first uncommon character in completions in *Completions* buffer." |
| 1040 | :group 'completion) |
| 1041 | |
| 1042 | (defface completions-common-part |
| 1043 | '((t (:inherit default))) |
| 1044 | "Face put on the common prefix substring in completions in *Completions* buffer. |
| 1045 | The idea of `completions-common-part' is that you can use it to |
| 1046 | make the common parts less visible than normal, so that the rest |
| 1047 | of the differing parts is, by contrast, slightly highlighted." |
| 1048 | :group 'completion) |
| 1049 | |
| 1050 | (defun completion-hilit-commonality (completions prefix-len base-size) |
| 1051 | (when completions |
| 1052 | (let ((com-str-len (- prefix-len (or base-size 0)))) |
| 1053 | (nconc |
| 1054 | (mapcar |
| 1055 | (lambda (elem) |
| 1056 | (let ((str |
| 1057 | ;; Don't modify the string itself, but a copy, since the |
| 1058 | ;; the string may be read-only or used for other purposes. |
| 1059 | ;; Furthermore, since `completions' may come from |
| 1060 | ;; display-completion-list, `elem' may be a list. |
| 1061 | (if (consp elem) |
| 1062 | (car (setq elem (cons (copy-sequence (car elem)) |
| 1063 | (cdr elem)))) |
| 1064 | (setq elem (copy-sequence elem))))) |
| 1065 | (put-text-property 0 |
| 1066 | ;; If completion-boundaries returns incorrect |
| 1067 | ;; values, all-completions may return strings |
| 1068 | ;; that don't contain the prefix. |
| 1069 | (min com-str-len (length str)) |
| 1070 | 'font-lock-face 'completions-common-part |
| 1071 | str) |
| 1072 | (if (> (length str) com-str-len) |
| 1073 | (put-text-property com-str-len (1+ com-str-len) |
| 1074 | 'font-lock-face 'completions-first-difference |
| 1075 | str))) |
| 1076 | elem) |
| 1077 | completions) |
| 1078 | base-size)))) |
| 1079 | |
| 1080 | (defun display-completion-list (completions &optional common-substring) |
| 1081 | "Display the list of completions, COMPLETIONS, using `standard-output'. |
| 1082 | Each element may be just a symbol or string |
| 1083 | or may be a list of two strings to be printed as if concatenated. |
| 1084 | If it is a list of two strings, the first is the actual completion |
| 1085 | alternative, the second serves as annotation. |
| 1086 | `standard-output' must be a buffer. |
| 1087 | The actual completion alternatives, as inserted, are given `mouse-face' |
| 1088 | properties of `highlight'. |
| 1089 | At the end, this runs the normal hook `completion-setup-hook'. |
| 1090 | It can find the completion buffer in `standard-output'. |
| 1091 | |
| 1092 | The obsolete optional arg COMMON-SUBSTRING, if non-nil, should be a string |
| 1093 | specifying a common substring for adding the faces |
| 1094 | `completions-first-difference' and `completions-common-part' to |
| 1095 | the completions buffer." |
| 1096 | (if common-substring |
| 1097 | (setq completions (completion-hilit-commonality |
| 1098 | completions (length common-substring) |
| 1099 | ;; We don't know the base-size. |
| 1100 | nil))) |
| 1101 | (if (not (bufferp standard-output)) |
| 1102 | ;; This *never* (ever) happens, so there's no point trying to be clever. |
| 1103 | (with-temp-buffer |
| 1104 | (let ((standard-output (current-buffer)) |
| 1105 | (completion-setup-hook nil)) |
| 1106 | (display-completion-list completions common-substring)) |
| 1107 | (princ (buffer-string))) |
| 1108 | |
| 1109 | (with-current-buffer standard-output |
| 1110 | (goto-char (point-max)) |
| 1111 | (if (null completions) |
| 1112 | (insert "There are no possible completions of what you have typed.") |
| 1113 | (insert "Possible completions are:\n") |
| 1114 | (completion--insert-strings completions)))) |
| 1115 | |
| 1116 | ;; The hilit used to be applied via completion-setup-hook, so there |
| 1117 | ;; may still be some code that uses completion-common-substring. |
| 1118 | (with-no-warnings |
| 1119 | (let ((completion-common-substring common-substring)) |
| 1120 | (run-hooks 'completion-setup-hook))) |
| 1121 | nil) |
| 1122 | |
| 1123 | (defvar completion-annotate-function |
| 1124 | nil |
| 1125 | ;; Note: there's a lot of scope as for when to add annotations and |
| 1126 | ;; what annotations to add. E.g. completing-help.el allowed adding |
| 1127 | ;; the first line of docstrings to M-x completion. But there's |
| 1128 | ;; a tension, since such annotations, while useful at times, can |
| 1129 | ;; actually drown the useful information. |
| 1130 | ;; So completion-annotate-function should be used parsimoniously, or |
| 1131 | ;; else only used upon a user's request (e.g. we could add a command |
| 1132 | ;; to completion-list-mode to add annotations to the current |
| 1133 | ;; completions). |
| 1134 | "Function to add annotations in the *Completions* buffer. |
| 1135 | The function takes a completion and should either return nil, or a string that |
| 1136 | will be displayed next to the completion. The function can access the |
| 1137 | completion table and predicates via `minibuffer-completion-table' and related |
| 1138 | variables.") |
| 1139 | |
| 1140 | (defun minibuffer-completion-help () |
| 1141 | "Display a list of possible completions of the current minibuffer contents." |
| 1142 | (interactive) |
| 1143 | (message "Making completion list...") |
| 1144 | (lexical-let* ((start (field-beginning)) |
| 1145 | (end (field-end)) |
| 1146 | (string (field-string)) |
| 1147 | (completions (completion-all-completions |
| 1148 | string |
| 1149 | minibuffer-completion-table |
| 1150 | minibuffer-completion-predicate |
| 1151 | (- (point) (field-beginning))))) |
| 1152 | (message nil) |
| 1153 | (if (and completions |
| 1154 | (or (consp (cdr completions)) |
| 1155 | (not (equal (car completions) string)))) |
| 1156 | (let* ((last (last completions)) |
| 1157 | (base-size (cdr last)) |
| 1158 | ;; If the *Completions* buffer is shown in a new |
| 1159 | ;; window, mark it as softly-dedicated, so bury-buffer in |
| 1160 | ;; minibuffer-hide-completions will know whether to |
| 1161 | ;; delete the window or not. |
| 1162 | (display-buffer-mark-dedicated 'soft)) |
| 1163 | (with-output-to-temp-buffer "*Completions*" |
| 1164 | ;; Remove the base-size tail because `sort' requires a properly |
| 1165 | ;; nil-terminated list. |
| 1166 | (when last (setcdr last nil)) |
| 1167 | (setq completions (sort completions 'string-lessp)) |
| 1168 | (when completion-annotate-function |
| 1169 | (setq completions |
| 1170 | (mapcar (lambda (s) |
| 1171 | (let ((ann |
| 1172 | (funcall completion-annotate-function s))) |
| 1173 | (if ann (list s ann) s))) |
| 1174 | completions))) |
| 1175 | (with-current-buffer standard-output |
| 1176 | (set (make-local-variable 'completion-base-position) |
| 1177 | (list (+ start base-size) |
| 1178 | ;; FIXME: We should pay attention to completion |
| 1179 | ;; boundaries here, but currently |
| 1180 | ;; completion-all-completions does not give us the |
| 1181 | ;; necessary information. |
| 1182 | end))) |
| 1183 | (display-completion-list completions))) |
| 1184 | |
| 1185 | ;; If there are no completions, or if the current input is already the |
| 1186 | ;; only possible completion, then hide (previous&stale) completions. |
| 1187 | (minibuffer-hide-completions) |
| 1188 | (ding) |
| 1189 | (minibuffer-message |
| 1190 | (if completions "Sole completion" "No completions"))) |
| 1191 | nil)) |
| 1192 | |
| 1193 | (defun minibuffer-hide-completions () |
| 1194 | "Get rid of an out-of-date *Completions* buffer." |
| 1195 | ;; FIXME: We could/should use minibuffer-scroll-window here, but it |
| 1196 | ;; can also point to the minibuffer-parent-window, so it's a bit tricky. |
| 1197 | (let ((win (get-buffer-window "*Completions*" 0))) |
| 1198 | (if win (with-selected-window win (bury-buffer))))) |
| 1199 | |
| 1200 | (defun exit-minibuffer () |
| 1201 | "Terminate this minibuffer argument." |
| 1202 | (interactive) |
| 1203 | ;; If the command that uses this has made modifications in the minibuffer, |
| 1204 | ;; we don't want them to cause deactivation of the mark in the original |
| 1205 | ;; buffer. |
| 1206 | ;; A better solution would be to make deactivate-mark buffer-local |
| 1207 | ;; (or to turn it into a list of buffers, ...), but in the mean time, |
| 1208 | ;; this should do the trick in most cases. |
| 1209 | (setq deactivate-mark nil) |
| 1210 | (throw 'exit nil)) |
| 1211 | |
| 1212 | (defun self-insert-and-exit () |
| 1213 | "Terminate minibuffer input." |
| 1214 | (interactive) |
| 1215 | (if (characterp last-command-event) |
| 1216 | (call-interactively 'self-insert-command) |
| 1217 | (ding)) |
| 1218 | (exit-minibuffer)) |
| 1219 | |
| 1220 | (defvar completion-in-region-functions nil |
| 1221 | "Wrapper hook around `completion-in-region'. |
| 1222 | The functions on this special hook are called with 5 arguments: |
| 1223 | NEXT-FUN START END COLLECTION PREDICATE. |
| 1224 | NEXT-FUN is a function of four arguments (START END COLLECTION PREDICATE) |
| 1225 | that performs the default operation. The other four arguments are like |
| 1226 | the ones passed to `completion-in-region'. The functions on this hook |
| 1227 | are expected to perform completion on START..END using COLLECTION |
| 1228 | and PREDICATE, either by calling NEXT-FUN or by doing it themselves.") |
| 1229 | |
| 1230 | (defun completion-in-region (start end collection &optional predicate) |
| 1231 | "Complete the text between START and END using COLLECTION. |
| 1232 | Return nil if there is no valid completion, else t. |
| 1233 | Point needs to be somewhere between START and END." |
| 1234 | (assert (<= start (point)) (<= (point) end)) |
| 1235 | ;; FIXME: undisplay the *Completions* buffer once the completion is done. |
| 1236 | (with-wrapper-hook |
| 1237 | completion-in-region-functions (start end collection predicate) |
| 1238 | (let ((minibuffer-completion-table collection) |
| 1239 | (minibuffer-completion-predicate predicate) |
| 1240 | (ol (make-overlay start end nil nil t))) |
| 1241 | (overlay-put ol 'field 'completion) |
| 1242 | (unwind-protect |
| 1243 | (call-interactively 'minibuffer-complete) |
| 1244 | (delete-overlay ol))))) |
| 1245 | |
| 1246 | (defvar completion-at-point-functions '(tags-completion-at-point-function) |
| 1247 | "Special hook to find the completion table for the thing at point. |
| 1248 | It is called without any argument and should return either nil, |
| 1249 | or a function of no argument to perform completion (discouraged), |
| 1250 | or a list of the form (START END COLLECTION &rest PROPS) where |
| 1251 | START and END delimit the entity to complete and should include point, |
| 1252 | COLLECTION is the completion table to use to complete it, and |
| 1253 | PROPS is a property list for additional information. |
| 1254 | Currently supported properties are: |
| 1255 | `:predicate' a predicate that completion candidates need to satisfy. |
| 1256 | `:annotation-function' the value to use for `completion-annotate-function'.") |
| 1257 | |
| 1258 | (defun completion-at-point () |
| 1259 | "Perform completion on the text around point. |
| 1260 | The completion method is determined by `completion-at-point-functions'." |
| 1261 | (interactive) |
| 1262 | (let ((res (run-hook-with-args-until-success |
| 1263 | 'completion-at-point-functions))) |
| 1264 | (cond |
| 1265 | ((functionp res) (funcall res)) |
| 1266 | (res |
| 1267 | (let* ((plist (nthcdr 3 res)) |
| 1268 | (start (nth 0 res)) |
| 1269 | (end (nth 1 res)) |
| 1270 | (completion-annotate-function |
| 1271 | (or (plist-get plist :annotation-function) |
| 1272 | completion-annotate-function))) |
| 1273 | (completion-in-region start end (nth 2 res) |
| 1274 | (plist-get plist :predicate))))))) |
| 1275 | |
| 1276 | ;;; Key bindings. |
| 1277 | |
| 1278 | (define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map |
| 1279 | 'minibuffer-local-filename-must-match-map "23.1") |
| 1280 | |
| 1281 | (let ((map minibuffer-local-map)) |
| 1282 | (define-key map "\C-g" 'abort-recursive-edit) |
| 1283 | (define-key map "\r" 'exit-minibuffer) |
| 1284 | (define-key map "\n" 'exit-minibuffer)) |
| 1285 | |
| 1286 | (let ((map minibuffer-local-completion-map)) |
| 1287 | (define-key map "\t" 'minibuffer-complete) |
| 1288 | ;; M-TAB is already abused for many other purposes, so we should find |
| 1289 | ;; another binding for it. |
| 1290 | ;; (define-key map "\e\t" 'minibuffer-force-complete) |
| 1291 | (define-key map " " 'minibuffer-complete-word) |
| 1292 | (define-key map "?" 'minibuffer-completion-help)) |
| 1293 | |
| 1294 | (let ((map minibuffer-local-must-match-map)) |
| 1295 | (define-key map "\r" 'minibuffer-complete-and-exit) |
| 1296 | (define-key map "\n" 'minibuffer-complete-and-exit)) |
| 1297 | |
| 1298 | (let ((map minibuffer-local-filename-completion-map)) |
| 1299 | (define-key map " " nil)) |
| 1300 | (let ((map minibuffer-local-filename-must-match-map)) |
| 1301 | (define-key map " " nil)) |
| 1302 | |
| 1303 | (let ((map minibuffer-local-ns-map)) |
| 1304 | (define-key map " " 'exit-minibuffer) |
| 1305 | (define-key map "\t" 'exit-minibuffer) |
| 1306 | (define-key map "?" 'self-insert-and-exit)) |
| 1307 | |
| 1308 | ;;; Completion tables. |
| 1309 | |
| 1310 | (defun minibuffer--double-dollars (str) |
| 1311 | (replace-regexp-in-string "\\$" "$$" str)) |
| 1312 | |
| 1313 | (defun completion--make-envvar-table () |
| 1314 | (mapcar (lambda (enventry) |
| 1315 | (substring enventry 0 (string-match-p "=" enventry))) |
| 1316 | process-environment)) |
| 1317 | |
| 1318 | (defconst completion--embedded-envvar-re |
| 1319 | (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)" |
| 1320 | "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'")) |
| 1321 | |
| 1322 | (defun completion--embedded-envvar-table (string pred action) |
| 1323 | "Completion table for envvars embedded in a string. |
| 1324 | The envvar syntax (and escaping) rules followed by this table are the |
| 1325 | same as `substitute-in-file-name'." |
| 1326 | ;; We ignore `pred', because the predicates passed to us via |
| 1327 | ;; read-file-name-internal are not 100% correct and fail here: |
| 1328 | ;; e.g. we get predicates like file-directory-p there, whereas the filename |
| 1329 | ;; completed needs to be passed through substitute-in-file-name before it |
| 1330 | ;; can be passed to file-directory-p. |
| 1331 | (when (string-match completion--embedded-envvar-re string) |
| 1332 | (let* ((beg (or (match-beginning 2) (match-beginning 1))) |
| 1333 | (table (completion--make-envvar-table)) |
| 1334 | (prefix (substring string 0 beg))) |
| 1335 | (cond |
| 1336 | ((eq action 'lambda) |
| 1337 | ;; This table is expected to be used in conjunction with some |
| 1338 | ;; other table that provides the "main" completion. Let the |
| 1339 | ;; other table handle the test-completion case. |
| 1340 | nil) |
| 1341 | ((eq (car-safe action) 'boundaries) |
| 1342 | ;; Only return boundaries if there's something to complete, |
| 1343 | ;; since otherwise when we're used in |
| 1344 | ;; completion-table-in-turn, we could return boundaries and |
| 1345 | ;; let some subsequent table return a list of completions. |
| 1346 | ;; FIXME: Maybe it should rather be fixed in |
| 1347 | ;; completion-table-in-turn instead, but it's difficult to |
| 1348 | ;; do it efficiently there. |
| 1349 | (when (try-completion (substring string beg) table nil) |
| 1350 | ;; Compute the boundaries of the subfield to which this |
| 1351 | ;; completion applies. |
| 1352 | (let ((suffix (cdr action))) |
| 1353 | (list* 'boundaries |
| 1354 | (or (match-beginning 2) (match-beginning 1)) |
| 1355 | (when (string-match "[^[:alnum:]_]" suffix) |
| 1356 | (match-beginning 0)))))) |
| 1357 | (t |
| 1358 | (if (eq (aref string (1- beg)) ?{) |
| 1359 | (setq table (apply-partially 'completion-table-with-terminator |
| 1360 | "}" table))) |
| 1361 | ;; Even if file-name completion is case-insensitive, we want |
| 1362 | ;; envvar completion to be case-sensitive. |
| 1363 | (let ((completion-ignore-case nil)) |
| 1364 | (completion-table-with-context |
| 1365 | prefix table (substring string beg) nil action))))))) |
| 1366 | |
| 1367 | (defun completion-file-name-table (string pred action) |
| 1368 | "Completion table for file names." |
| 1369 | (ignore-errors |
| 1370 | (cond |
| 1371 | ((eq (car-safe action) 'boundaries) |
| 1372 | (let ((start (length (file-name-directory string))) |
| 1373 | (end (string-match-p "/" (cdr action)))) |
| 1374 | (list* 'boundaries |
| 1375 | ;; if `string' is "C:" in w32, (file-name-directory string) |
| 1376 | ;; returns "C:/", so `start' is 3 rather than 2. |
| 1377 | ;; Not quite sure what is The Right Fix, but clipping it |
| 1378 | ;; back to 2 will work for this particular case. We'll |
| 1379 | ;; see if we can come up with a better fix when we bump |
| 1380 | ;; into more such problematic cases. |
| 1381 | (min start (length string)) end))) |
| 1382 | |
| 1383 | ((eq action 'lambda) |
| 1384 | (if (zerop (length string)) |
| 1385 | nil ;Not sure why it's here, but it probably doesn't harm. |
| 1386 | (funcall (or pred 'file-exists-p) string))) |
| 1387 | |
| 1388 | (t |
| 1389 | (let* ((name (file-name-nondirectory string)) |
| 1390 | (specdir (file-name-directory string)) |
| 1391 | (realdir (or specdir default-directory))) |
| 1392 | |
| 1393 | (cond |
| 1394 | ((null action) |
| 1395 | (let ((comp (file-name-completion name realdir pred))) |
| 1396 | (if (stringp comp) |
| 1397 | (concat specdir comp) |
| 1398 | comp))) |
| 1399 | |
| 1400 | ((eq action t) |
| 1401 | (let ((all (file-name-all-completions name realdir))) |
| 1402 | |
| 1403 | ;; Check the predicate, if necessary. |
| 1404 | (unless (memq pred '(nil file-exists-p)) |
| 1405 | (let ((comp ()) |
| 1406 | (pred |
| 1407 | (if (eq pred 'file-directory-p) |
| 1408 | ;; Brute-force speed up for directory checking: |
| 1409 | ;; Discard strings which don't end in a slash. |
| 1410 | (lambda (s) |
| 1411 | (let ((len (length s))) |
| 1412 | (and (> len 0) (eq (aref s (1- len)) ?/)))) |
| 1413 | ;; Must do it the hard (and slow) way. |
| 1414 | pred))) |
| 1415 | (let ((default-directory (expand-file-name realdir))) |
| 1416 | (dolist (tem all) |
| 1417 | (if (funcall pred tem) (push tem comp)))) |
| 1418 | (setq all (nreverse comp)))) |
| 1419 | |
| 1420 | all)))))))) |
| 1421 | |
| 1422 | (defvar read-file-name-predicate nil |
| 1423 | "Current predicate used by `read-file-name-internal'.") |
| 1424 | (make-obsolete-variable 'read-file-name-predicate |
| 1425 | "use the regular PRED argument" "23.2") |
| 1426 | |
| 1427 | (defun completion--file-name-table (string pred action) |
| 1428 | "Internal subroutine for `read-file-name'. Do not call this. |
| 1429 | This is a completion table for file names, like `completion-file-name-table' |
| 1430 | except that it passes the file name through `substitute-in-file-name'." |
| 1431 | (cond |
| 1432 | ((eq (car-safe action) 'boundaries) |
| 1433 | ;; For the boundaries, we can't really delegate to |
| 1434 | ;; substitute-in-file-name+completion-file-name-table and then fix |
| 1435 | ;; them up (as we do for the other actions), because it would |
| 1436 | ;; require us to track the relationship between `str' and |
| 1437 | ;; `string', which is difficult. And in any case, if |
| 1438 | ;; substitute-in-file-name turns "fo-$TO-ba" into "fo-o/b-ba", |
| 1439 | ;; there's no way for us to return proper boundaries info, because |
| 1440 | ;; the boundary is not (yet) in `string'. |
| 1441 | ;; |
| 1442 | ;; FIXME: Actually there is a way to return correct boundaries |
| 1443 | ;; info, at the condition of modifying the all-completions |
| 1444 | ;; return accordingly. But for now, let's not bother. |
| 1445 | (completion-file-name-table string pred action)) |
| 1446 | |
| 1447 | (t |
| 1448 | (let* ((default-directory |
| 1449 | (if (stringp pred) |
| 1450 | ;; It used to be that `pred' was abused to pass `dir' |
| 1451 | ;; as an argument. |
| 1452 | (prog1 (file-name-as-directory (expand-file-name pred)) |
| 1453 | (setq pred nil)) |
| 1454 | default-directory)) |
| 1455 | (str (condition-case nil |
| 1456 | (substitute-in-file-name string) |
| 1457 | (error string))) |
| 1458 | (comp (completion-file-name-table |
| 1459 | str |
| 1460 | (with-no-warnings (or pred read-file-name-predicate)) |
| 1461 | action))) |
| 1462 | |
| 1463 | (cond |
| 1464 | ((stringp comp) |
| 1465 | ;; Requote the $s before returning the completion. |
| 1466 | (minibuffer--double-dollars comp)) |
| 1467 | ((and (null action) comp |
| 1468 | ;; Requote the $s before checking for changes. |
| 1469 | (setq str (minibuffer--double-dollars str)) |
| 1470 | (not (string-equal string str))) |
| 1471 | ;; If there's no real completion, but substitute-in-file-name |
| 1472 | ;; changed the string, then return the new string. |
| 1473 | str) |
| 1474 | (t comp)))))) |
| 1475 | |
| 1476 | (defalias 'read-file-name-internal |
| 1477 | (completion-table-in-turn 'completion--embedded-envvar-table |
| 1478 | 'completion--file-name-table) |
| 1479 | "Internal subroutine for `read-file-name'. Do not call this.") |
| 1480 | |
| 1481 | (defvar read-file-name-function nil |
| 1482 | "If this is non-nil, `read-file-name' does its work by calling this function.") |
| 1483 | |
| 1484 | (defcustom read-file-name-completion-ignore-case |
| 1485 | (if (memq system-type '(ms-dos windows-nt darwin cygwin)) |
| 1486 | t nil) |
| 1487 | "Non-nil means when reading a file name completion ignores case." |
| 1488 | :group 'minibuffer |
| 1489 | :type 'boolean |
| 1490 | :version "22.1") |
| 1491 | |
| 1492 | (defcustom insert-default-directory t |
| 1493 | "Non-nil means when reading a filename start with default dir in minibuffer. |
| 1494 | |
| 1495 | When the initial minibuffer contents show a name of a file or a directory, |
| 1496 | typing RETURN without editing the initial contents is equivalent to typing |
| 1497 | the default file name. |
| 1498 | |
| 1499 | If this variable is non-nil, the minibuffer contents are always |
| 1500 | initially non-empty, and typing RETURN without editing will fetch the |
| 1501 | default name, if one is provided. Note however that this default name |
| 1502 | is not necessarily the same as initial contents inserted in the minibuffer, |
| 1503 | if the initial contents is just the default directory. |
| 1504 | |
| 1505 | If this variable is nil, the minibuffer often starts out empty. In |
| 1506 | that case you may have to explicitly fetch the next history element to |
| 1507 | request the default name; typing RETURN without editing will leave |
| 1508 | the minibuffer empty. |
| 1509 | |
| 1510 | For some commands, exiting with an empty minibuffer has a special meaning, |
| 1511 | such as making the current buffer visit no file in the case of |
| 1512 | `set-visited-file-name'." |
| 1513 | :group 'minibuffer |
| 1514 | :type 'boolean) |
| 1515 | |
| 1516 | ;; Not always defined, but only called if next-read-file-uses-dialog-p says so. |
| 1517 | (declare-function x-file-dialog "xfns.c" |
| 1518 | (prompt dir &optional default-filename mustmatch only-dir-p)) |
| 1519 | |
| 1520 | (defun read-file-name-defaults (&optional dir initial) |
| 1521 | (let ((default |
| 1522 | (cond |
| 1523 | ;; With non-nil `initial', use `dir' as the first default. |
| 1524 | ;; Essentially, this mean reversing the normal order of the |
| 1525 | ;; current directory name and the current file name, i.e. |
| 1526 | ;; 1. with normal file reading: |
| 1527 | ;; 1.1. initial input is the current directory |
| 1528 | ;; 1.2. the first default is the current file name |
| 1529 | ;; 2. with non-nil `initial' (e.g. for `find-alternate-file'): |
| 1530 | ;; 2.2. initial input is the current file name |
| 1531 | ;; 2.1. the first default is the current directory |
| 1532 | (initial (abbreviate-file-name dir)) |
| 1533 | ;; In file buffers, try to get the current file name |
| 1534 | (buffer-file-name |
| 1535 | (abbreviate-file-name buffer-file-name)))) |
| 1536 | (file-name-at-point |
| 1537 | (run-hook-with-args-until-success 'file-name-at-point-functions))) |
| 1538 | (when file-name-at-point |
| 1539 | (setq default (delete-dups |
| 1540 | (delete "" (delq nil (list file-name-at-point default)))))) |
| 1541 | ;; Append new defaults to the end of existing `minibuffer-default'. |
| 1542 | (append |
| 1543 | (if (listp minibuffer-default) minibuffer-default (list minibuffer-default)) |
| 1544 | (if (listp default) default (list default))))) |
| 1545 | |
| 1546 | (defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate) |
| 1547 | "Read file name, prompting with PROMPT and completing in directory DIR. |
| 1548 | Value is not expanded---you must call `expand-file-name' yourself. |
| 1549 | Default name to DEFAULT-FILENAME if user exits the minibuffer with |
| 1550 | the same non-empty string that was inserted by this function. |
| 1551 | (If DEFAULT-FILENAME is omitted, the visited file name is used, |
| 1552 | except that if INITIAL is specified, that combined with DIR is used. |
| 1553 | If DEFAULT-FILENAME is a list of file names, the first file name is used.) |
| 1554 | If the user exits with an empty minibuffer, this function returns |
| 1555 | an empty string. (This can only happen if the user erased the |
| 1556 | pre-inserted contents or if `insert-default-directory' is nil.) |
| 1557 | |
| 1558 | Fourth arg MUSTMATCH can take the following values: |
| 1559 | - nil means that the user can exit with any input. |
| 1560 | - t means that the user is not allowed to exit unless |
| 1561 | the input is (or completes to) an existing file. |
| 1562 | - `confirm' means that the user can exit with any input, but she needs |
| 1563 | to confirm her choice if the input is not an existing file. |
| 1564 | - `confirm-after-completion' means that the user can exit with any |
| 1565 | input, but she needs to confirm her choice if she called |
| 1566 | `minibuffer-complete' right before `minibuffer-complete-and-exit' |
| 1567 | and the input is not an existing file. |
| 1568 | - anything else behaves like t except that typing RET does not exit if it |
| 1569 | does non-null completion. |
| 1570 | |
| 1571 | Fifth arg INITIAL specifies text to start with. |
| 1572 | |
| 1573 | If optional sixth arg PREDICATE is non-nil, possible completions and |
| 1574 | the resulting file name must satisfy (funcall PREDICATE NAME). |
| 1575 | DIR should be an absolute directory name. It defaults to the value of |
| 1576 | `default-directory'. |
| 1577 | |
| 1578 | If this command was invoked with the mouse, use a graphical file |
| 1579 | dialog if `use-dialog-box' is non-nil, and the window system or X |
| 1580 | toolkit in use provides a file dialog box, and DIR is not a |
| 1581 | remote file. For graphical file dialogs, any the special values |
| 1582 | of MUSTMATCH; `confirm' and `confirm-after-completion' are |
| 1583 | treated as equivalent to nil. |
| 1584 | |
| 1585 | See also `read-file-name-completion-ignore-case' |
| 1586 | and `read-file-name-function'." |
| 1587 | (unless dir (setq dir default-directory)) |
| 1588 | (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir))) |
| 1589 | (unless default-filename |
| 1590 | (setq default-filename (if initial (expand-file-name initial dir) |
| 1591 | buffer-file-name))) |
| 1592 | ;; If dir starts with user's homedir, change that to ~. |
| 1593 | (setq dir (abbreviate-file-name dir)) |
| 1594 | ;; Likewise for default-filename. |
| 1595 | (if default-filename |
| 1596 | (setq default-filename |
| 1597 | (if (consp default-filename) |
| 1598 | (mapcar 'abbreviate-file-name default-filename) |
| 1599 | (abbreviate-file-name default-filename)))) |
| 1600 | (let ((insdef (cond |
| 1601 | ((and insert-default-directory (stringp dir)) |
| 1602 | (if initial |
| 1603 | (cons (minibuffer--double-dollars (concat dir initial)) |
| 1604 | (length (minibuffer--double-dollars dir))) |
| 1605 | (minibuffer--double-dollars dir))) |
| 1606 | (initial (cons (minibuffer--double-dollars initial) 0))))) |
| 1607 | |
| 1608 | (if read-file-name-function |
| 1609 | (funcall read-file-name-function |
| 1610 | prompt dir default-filename mustmatch initial predicate) |
| 1611 | (let ((completion-ignore-case read-file-name-completion-ignore-case) |
| 1612 | (minibuffer-completing-file-name t) |
| 1613 | (pred (or predicate 'file-exists-p)) |
| 1614 | (add-to-history nil)) |
| 1615 | |
| 1616 | (let* ((val |
| 1617 | (if (or (not (next-read-file-uses-dialog-p)) |
| 1618 | ;; Graphical file dialogs can't handle remote |
| 1619 | ;; files (Bug#99). |
| 1620 | (file-remote-p dir)) |
| 1621 | ;; We used to pass `dir' to `read-file-name-internal' by |
| 1622 | ;; abusing the `predicate' argument. It's better to |
| 1623 | ;; just use `default-directory', but in order to avoid |
| 1624 | ;; changing `default-directory' in the current buffer, |
| 1625 | ;; we don't let-bind it. |
| 1626 | (lexical-let ((dir (file-name-as-directory |
| 1627 | (expand-file-name dir)))) |
| 1628 | (minibuffer-with-setup-hook |
| 1629 | (lambda () |
| 1630 | (setq default-directory dir) |
| 1631 | ;; When the first default in `minibuffer-default' |
| 1632 | ;; duplicates initial input `insdef', |
| 1633 | ;; reset `minibuffer-default' to nil. |
| 1634 | (when (equal (or (car-safe insdef) insdef) |
| 1635 | (or (car-safe minibuffer-default) |
| 1636 | minibuffer-default)) |
| 1637 | (setq minibuffer-default |
| 1638 | (cdr-safe minibuffer-default))) |
| 1639 | ;; On the first request on `M-n' fill |
| 1640 | ;; `minibuffer-default' with a list of defaults |
| 1641 | ;; relevant for file-name reading. |
| 1642 | (set (make-local-variable 'minibuffer-default-add-function) |
| 1643 | (lambda () |
| 1644 | (with-current-buffer |
| 1645 | (window-buffer (minibuffer-selected-window)) |
| 1646 | (read-file-name-defaults dir initial))))) |
| 1647 | (completing-read prompt 'read-file-name-internal |
| 1648 | pred mustmatch insdef |
| 1649 | 'file-name-history default-filename))) |
| 1650 | ;; If DEFAULT-FILENAME not supplied and DIR contains |
| 1651 | ;; a file name, split it. |
| 1652 | (let ((file (file-name-nondirectory dir)) |
| 1653 | ;; When using a dialog, revert to nil and non-nil |
| 1654 | ;; interpretation of mustmatch. confirm options |
| 1655 | ;; need to be interpreted as nil, otherwise |
| 1656 | ;; it is impossible to create new files using |
| 1657 | ;; dialogs with the default settings. |
| 1658 | (dialog-mustmatch |
| 1659 | (not (memq mustmatch |
| 1660 | '(nil confirm confirm-after-completion))))) |
| 1661 | (when (and (not default-filename) |
| 1662 | (not (zerop (length file)))) |
| 1663 | (setq default-filename file) |
| 1664 | (setq dir (file-name-directory dir))) |
| 1665 | (when default-filename |
| 1666 | (setq default-filename |
| 1667 | (expand-file-name (if (consp default-filename) |
| 1668 | (car default-filename) |
| 1669 | default-filename) |
| 1670 | dir))) |
| 1671 | (setq add-to-history t) |
| 1672 | (x-file-dialog prompt dir default-filename |
| 1673 | dialog-mustmatch |
| 1674 | (eq predicate 'file-directory-p))))) |
| 1675 | |
| 1676 | (replace-in-history (eq (car-safe file-name-history) val))) |
| 1677 | ;; If completing-read returned the inserted default string itself |
| 1678 | ;; (rather than a new string with the same contents), |
| 1679 | ;; it has to mean that the user typed RET with the minibuffer empty. |
| 1680 | ;; In that case, we really want to return "" |
| 1681 | ;; so that commands such as set-visited-file-name can distinguish. |
| 1682 | (when (consp default-filename) |
| 1683 | (setq default-filename (car default-filename))) |
| 1684 | (when (eq val default-filename) |
| 1685 | ;; In this case, completing-read has not added an element |
| 1686 | ;; to the history. Maybe we should. |
| 1687 | (if (not replace-in-history) |
| 1688 | (setq add-to-history t)) |
| 1689 | (setq val "")) |
| 1690 | (unless val (error "No file name specified")) |
| 1691 | |
| 1692 | (if (and default-filename |
| 1693 | (string-equal val (if (consp insdef) (car insdef) insdef))) |
| 1694 | (setq val default-filename)) |
| 1695 | (setq val (substitute-in-file-name val)) |
| 1696 | |
| 1697 | (if replace-in-history |
| 1698 | ;; Replace what Fcompleting_read added to the history |
| 1699 | ;; with what we will actually return. As an exception, |
| 1700 | ;; if that's the same as the second item in |
| 1701 | ;; file-name-history, it's really a repeat (Bug#4657). |
| 1702 | (let ((val1 (minibuffer--double-dollars val))) |
| 1703 | (if history-delete-duplicates |
| 1704 | (setcdr file-name-history |
| 1705 | (delete val1 (cdr file-name-history)))) |
| 1706 | (if (string= val1 (cadr file-name-history)) |
| 1707 | (pop file-name-history) |
| 1708 | (setcar file-name-history val1))) |
| 1709 | (if add-to-history |
| 1710 | ;; Add the value to the history--but not if it matches |
| 1711 | ;; the last value already there. |
| 1712 | (let ((val1 (minibuffer--double-dollars val))) |
| 1713 | (unless (and (consp file-name-history) |
| 1714 | (equal (car file-name-history) val1)) |
| 1715 | (setq file-name-history |
| 1716 | (cons val1 |
| 1717 | (if history-delete-duplicates |
| 1718 | (delete val1 file-name-history) |
| 1719 | file-name-history))))))) |
| 1720 | val))))) |
| 1721 | |
| 1722 | (defun internal-complete-buffer-except (&optional buffer) |
| 1723 | "Perform completion on all buffers excluding BUFFER. |
| 1724 | BUFFER nil or omitted means use the current buffer. |
| 1725 | Like `internal-complete-buffer', but removes BUFFER from the completion list." |
| 1726 | (lexical-let ((except (if (stringp buffer) buffer (buffer-name buffer)))) |
| 1727 | (apply-partially 'completion-table-with-predicate |
| 1728 | 'internal-complete-buffer |
| 1729 | (lambda (name) |
| 1730 | (not (equal (if (consp name) (car name) name) except))) |
| 1731 | nil))) |
| 1732 | |
| 1733 | ;;; Old-style completion, used in Emacs-21 and Emacs-22. |
| 1734 | |
| 1735 | (defun completion-emacs21-try-completion (string table pred point) |
| 1736 | (let ((completion (try-completion string table pred))) |
| 1737 | (if (stringp completion) |
| 1738 | (cons completion (length completion)) |
| 1739 | completion))) |
| 1740 | |
| 1741 | (defun completion-emacs21-all-completions (string table pred point) |
| 1742 | (completion-hilit-commonality |
| 1743 | (all-completions string table pred) |
| 1744 | (length string) |
| 1745 | (car (completion-boundaries string table pred "")))) |
| 1746 | |
| 1747 | (defun completion-emacs22-try-completion (string table pred point) |
| 1748 | (let ((suffix (substring string point)) |
| 1749 | (completion (try-completion (substring string 0 point) table pred))) |
| 1750 | (if (not (stringp completion)) |
| 1751 | completion |
| 1752 | ;; Merge a trailing / in completion with a / after point. |
| 1753 | ;; We used to only do it for word completion, but it seems to make |
| 1754 | ;; sense for all completions. |
| 1755 | ;; Actually, claiming this feature was part of Emacs-22 completion |
| 1756 | ;; is pushing it a bit: it was only done in minibuffer-completion-word, |
| 1757 | ;; which was (by default) not bound during file completion, where such |
| 1758 | ;; slashes are most likely to occur. |
| 1759 | (if (and (not (zerop (length completion))) |
| 1760 | (eq ?/ (aref completion (1- (length completion)))) |
| 1761 | (not (zerop (length suffix))) |
| 1762 | (eq ?/ (aref suffix 0))) |
| 1763 | ;; This leaves point after the / . |
| 1764 | (setq suffix (substring suffix 1))) |
| 1765 | (cons (concat completion suffix) (length completion))))) |
| 1766 | |
| 1767 | (defun completion-emacs22-all-completions (string table pred point) |
| 1768 | (let ((beforepoint (substring string 0 point))) |
| 1769 | (completion-hilit-commonality |
| 1770 | (all-completions beforepoint table pred) |
| 1771 | point |
| 1772 | (car (completion-boundaries beforepoint table pred ""))))) |
| 1773 | |
| 1774 | ;;; Basic completion. |
| 1775 | |
| 1776 | (defun completion--merge-suffix (completion point suffix) |
| 1777 | "Merge end of COMPLETION with beginning of SUFFIX. |
| 1778 | Simple generalization of the \"merge trailing /\" done in Emacs-22. |
| 1779 | Return the new suffix." |
| 1780 | (if (and (not (zerop (length suffix))) |
| 1781 | (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix) |
| 1782 | ;; Make sure we don't compress things to less |
| 1783 | ;; than we started with. |
| 1784 | point) |
| 1785 | ;; Just make sure we didn't match some other \n. |
| 1786 | (eq (match-end 1) (length completion))) |
| 1787 | (substring suffix (- (match-end 1) (match-beginning 1))) |
| 1788 | ;; Nothing to merge. |
| 1789 | suffix)) |
| 1790 | |
| 1791 | (defun completion-basic--pattern (beforepoint afterpoint bounds) |
| 1792 | (delete |
| 1793 | "" (list (substring beforepoint (car bounds)) |
| 1794 | 'point |
| 1795 | (substring afterpoint 0 (cdr bounds))))) |
| 1796 | |
| 1797 | (defun completion-basic-try-completion (string table pred point) |
| 1798 | (lexical-let* |
| 1799 | ((beforepoint (substring string 0 point)) |
| 1800 | (afterpoint (substring string point)) |
| 1801 | (bounds (completion-boundaries beforepoint table pred afterpoint))) |
| 1802 | (if (zerop (cdr bounds)) |
| 1803 | ;; `try-completion' may return a subtly different result |
| 1804 | ;; than `all+merge', so try to use it whenever possible. |
| 1805 | (let ((completion (try-completion beforepoint table pred))) |
| 1806 | (if (not (stringp completion)) |
| 1807 | completion |
| 1808 | (cons |
| 1809 | (concat completion |
| 1810 | (completion--merge-suffix completion point afterpoint)) |
| 1811 | (length completion)))) |
| 1812 | (lexical-let* |
| 1813 | ((suffix (substring afterpoint (cdr bounds))) |
| 1814 | (prefix (substring beforepoint 0 (car bounds))) |
| 1815 | (pattern (delete |
| 1816 | "" (list (substring beforepoint (car bounds)) |
| 1817 | 'point |
| 1818 | (substring afterpoint 0 (cdr bounds))))) |
| 1819 | (all (completion-pcm--all-completions prefix pattern table pred))) |
| 1820 | (if minibuffer-completing-file-name |
| 1821 | (setq all (completion-pcm--filename-try-filter all))) |
| 1822 | (completion-pcm--merge-try pattern all prefix suffix))))) |
| 1823 | |
| 1824 | (defun completion-basic-all-completions (string table pred point) |
| 1825 | (lexical-let* |
| 1826 | ((beforepoint (substring string 0 point)) |
| 1827 | (afterpoint (substring string point)) |
| 1828 | (bounds (completion-boundaries beforepoint table pred afterpoint)) |
| 1829 | (suffix (substring afterpoint (cdr bounds))) |
| 1830 | (prefix (substring beforepoint 0 (car bounds))) |
| 1831 | (pattern (delete |
| 1832 | "" (list (substring beforepoint (car bounds)) |
| 1833 | 'point |
| 1834 | (substring afterpoint 0 (cdr bounds))))) |
| 1835 | (all (completion-pcm--all-completions prefix pattern table pred))) |
| 1836 | (completion-hilit-commonality all point (car bounds)))) |
| 1837 | |
| 1838 | ;;; Partial-completion-mode style completion. |
| 1839 | |
| 1840 | (defvar completion-pcm--delim-wild-regex nil |
| 1841 | "Regular expression matching delimiters controlling the partial-completion. |
| 1842 | Typically, this regular expression simply matches a delimiter, meaning |
| 1843 | that completion can add something at (match-beginning 0), but if it has |
| 1844 | a submatch 1, then completion can add something at (match-end 1). |
| 1845 | This is used when the delimiter needs to be of size zero (e.g. the transition |
| 1846 | from lowercase to uppercase characters).") |
| 1847 | |
| 1848 | (defun completion-pcm--prepare-delim-re (delims) |
| 1849 | (setq completion-pcm--delim-wild-regex (concat "[" delims "*]"))) |
| 1850 | |
| 1851 | (defcustom completion-pcm-word-delimiters "-_./: " |
| 1852 | "A string of characters treated as word delimiters for completion. |
| 1853 | Some arcane rules: |
| 1854 | If `]' is in this string, it must come first. |
| 1855 | If `^' is in this string, it must not come first. |
| 1856 | If `-' is in this string, it must come first or right after `]'. |
| 1857 | In other words, if S is this string, then `[S]' must be a valid Emacs regular |
| 1858 | expression (not containing character ranges like `a-z')." |
| 1859 | :set (lambda (symbol value) |
| 1860 | (set-default symbol value) |
| 1861 | ;; Refresh other vars. |
| 1862 | (completion-pcm--prepare-delim-re value)) |
| 1863 | :initialize 'custom-initialize-reset |
| 1864 | :group 'minibuffer |
| 1865 | :type 'string) |
| 1866 | |
| 1867 | (defcustom completion-pcm-complete-word-inserts-delimiters nil |
| 1868 | "Treat the SPC or - inserted by `minibuffer-complete-word' as delimiters. |
| 1869 | Those chars are treated as delimiters iff this variable is non-nil. |
| 1870 | I.e. if non-nil, M-x SPC will just insert a \"-\" in the minibuffer, whereas |
| 1871 | if nil, it will list all possible commands in *Completions* because none of |
| 1872 | the commands start with a \"-\" or a SPC." |
| 1873 | :type 'boolean) |
| 1874 | |
| 1875 | (defun completion-pcm--pattern-trivial-p (pattern) |
| 1876 | (and (stringp (car pattern)) |
| 1877 | ;; It can be followed by `point' and "" and still be trivial. |
| 1878 | (let ((trivial t)) |
| 1879 | (dolist (elem (cdr pattern)) |
| 1880 | (unless (member elem '(point "")) |
| 1881 | (setq trivial nil))) |
| 1882 | trivial))) |
| 1883 | |
| 1884 | (defun completion-pcm--string->pattern (string &optional point) |
| 1885 | "Split STRING into a pattern. |
| 1886 | A pattern is a list where each element is either a string |
| 1887 | or a symbol chosen among `any', `star', `point', `prefix'." |
| 1888 | (if (and point (< point (length string))) |
| 1889 | (let ((prefix (substring string 0 point)) |
| 1890 | (suffix (substring string point))) |
| 1891 | (append (completion-pcm--string->pattern prefix) |
| 1892 | '(point) |
| 1893 | (completion-pcm--string->pattern suffix))) |
| 1894 | (let ((pattern nil) |
| 1895 | (p 0) |
| 1896 | (p0 0)) |
| 1897 | |
| 1898 | (while (and (setq p (string-match completion-pcm--delim-wild-regex |
| 1899 | string p)) |
| 1900 | (or completion-pcm-complete-word-inserts-delimiters |
| 1901 | ;; If the char was added by minibuffer-complete-word, |
| 1902 | ;; then don't treat it as a delimiter, otherwise |
| 1903 | ;; "M-x SPC" ends up inserting a "-" rather than listing |
| 1904 | ;; all completions. |
| 1905 | (not (get-text-property p 'completion-try-word string)))) |
| 1906 | ;; Usually, completion-pcm--delim-wild-regex matches a delimiter, |
| 1907 | ;; meaning that something can be added *before* it, but it can also |
| 1908 | ;; match a prefix and postfix, in which case something can be added |
| 1909 | ;; in-between (e.g. match [[:lower:]][[:upper:]]). |
| 1910 | ;; This is determined by the presence of a submatch-1 which delimits |
| 1911 | ;; the prefix. |
| 1912 | (if (match-end 1) (setq p (match-end 1))) |
| 1913 | (push (substring string p0 p) pattern) |
| 1914 | (if (eq (aref string p) ?*) |
| 1915 | (progn |
| 1916 | (push 'star pattern) |
| 1917 | (setq p0 (1+ p))) |
| 1918 | (push 'any pattern) |
| 1919 | (setq p0 p)) |
| 1920 | (incf p)) |
| 1921 | |
| 1922 | ;; An empty string might be erroneously added at the beginning. |
| 1923 | ;; It should be avoided properly, but it's so easy to remove it here. |
| 1924 | (delete "" (nreverse (cons (substring string p0) pattern)))))) |
| 1925 | |
| 1926 | (defun completion-pcm--pattern->regex (pattern &optional group) |
| 1927 | (let ((re |
| 1928 | (concat "\\`" |
| 1929 | (mapconcat |
| 1930 | (lambda (x) |
| 1931 | (cond |
| 1932 | ((stringp x) (regexp-quote x)) |
| 1933 | ((if (consp group) (memq x group) group) "\\(.*?\\)") |
| 1934 | (t ".*?"))) |
| 1935 | pattern |
| 1936 | "")))) |
| 1937 | ;; Avoid pathological backtracking. |
| 1938 | (while (string-match "\\.\\*\\?\\(?:\\\\[()]\\)*\\(\\.\\*\\?\\)" re) |
| 1939 | (setq re (replace-match "" t t re 1))) |
| 1940 | re)) |
| 1941 | |
| 1942 | (defun completion-pcm--all-completions (prefix pattern table pred) |
| 1943 | "Find all completions for PATTERN in TABLE obeying PRED. |
| 1944 | PATTERN is as returned by `completion-pcm--string->pattern'." |
| 1945 | ;; (assert (= (car (completion-boundaries prefix table pred "")) |
| 1946 | ;; (length prefix))) |
| 1947 | ;; Find an initial list of possible completions. |
| 1948 | (if (completion-pcm--pattern-trivial-p pattern) |
| 1949 | |
| 1950 | ;; Minibuffer contains no delimiters -- simple case! |
| 1951 | (all-completions (concat prefix (car pattern)) table pred) |
| 1952 | |
| 1953 | ;; Use all-completions to do an initial cull. This is a big win, |
| 1954 | ;; since all-completions is written in C! |
| 1955 | (let* (;; Convert search pattern to a standard regular expression. |
| 1956 | (regex (completion-pcm--pattern->regex pattern)) |
| 1957 | (case-fold-search completion-ignore-case) |
| 1958 | (completion-regexp-list (cons regex completion-regexp-list)) |
| 1959 | (compl (all-completions |
| 1960 | (concat prefix (if (stringp (car pattern)) (car pattern) "")) |
| 1961 | table pred))) |
| 1962 | (if (not (functionp table)) |
| 1963 | ;; The internal functions already obeyed completion-regexp-list. |
| 1964 | compl |
| 1965 | (let ((poss ())) |
| 1966 | (dolist (c compl) |
| 1967 | (when (string-match-p regex c) (push c poss))) |
| 1968 | poss))))) |
| 1969 | |
| 1970 | (defun completion-pcm--hilit-commonality (pattern completions) |
| 1971 | (when completions |
| 1972 | (let* ((re (completion-pcm--pattern->regex pattern '(point))) |
| 1973 | (case-fold-search completion-ignore-case)) |
| 1974 | (mapcar |
| 1975 | (lambda (str) |
| 1976 | ;; Don't modify the string itself. |
| 1977 | (setq str (copy-sequence str)) |
| 1978 | (unless (string-match re str) |
| 1979 | (error "Internal error: %s does not match %s" re str)) |
| 1980 | (let ((pos (or (match-beginning 1) (match-end 0)))) |
| 1981 | (put-text-property 0 pos |
| 1982 | 'font-lock-face 'completions-common-part |
| 1983 | str) |
| 1984 | (if (> (length str) pos) |
| 1985 | (put-text-property pos (1+ pos) |
| 1986 | 'font-lock-face 'completions-first-difference |
| 1987 | str))) |
| 1988 | str) |
| 1989 | completions)))) |
| 1990 | |
| 1991 | (defun completion-pcm--find-all-completions (string table pred point |
| 1992 | &optional filter) |
| 1993 | "Find all completions for STRING at POINT in TABLE, satisfying PRED. |
| 1994 | POINT is a position inside STRING. |
| 1995 | FILTER is a function applied to the return value, that can be used, e.g. to |
| 1996 | filter out additional entries (because TABLE migth not obey PRED)." |
| 1997 | (unless filter (setq filter 'identity)) |
| 1998 | (lexical-let* |
| 1999 | ((beforepoint (substring string 0 point)) |
| 2000 | (afterpoint (substring string point)) |
| 2001 | (bounds (completion-boundaries beforepoint table pred afterpoint)) |
| 2002 | (prefix (substring beforepoint 0 (car bounds))) |
| 2003 | (suffix (substring afterpoint (cdr bounds))) |
| 2004 | firsterror) |
| 2005 | (setq string (substring string (car bounds) (+ point (cdr bounds)))) |
| 2006 | (let* ((relpoint (- point (car bounds))) |
| 2007 | (pattern (completion-pcm--string->pattern string relpoint)) |
| 2008 | (all (condition-case err |
| 2009 | (funcall filter |
| 2010 | (completion-pcm--all-completions |
| 2011 | prefix pattern table pred)) |
| 2012 | (error (unless firsterror (setq firsterror err)) nil)))) |
| 2013 | (when (and (null all) |
| 2014 | (> (car bounds) 0) |
| 2015 | (null (ignore-errors (try-completion prefix table pred)))) |
| 2016 | ;; The prefix has no completions at all, so we should try and fix |
| 2017 | ;; that first. |
| 2018 | (let ((substring (substring prefix 0 -1))) |
| 2019 | (destructuring-bind (subpat suball subprefix subsuffix) |
| 2020 | (completion-pcm--find-all-completions |
| 2021 | substring table pred (length substring) filter) |
| 2022 | (let ((sep (aref prefix (1- (length prefix)))) |
| 2023 | ;; Text that goes between the new submatches and the |
| 2024 | ;; completion substring. |
| 2025 | (between nil)) |
| 2026 | ;; Eliminate submatches that don't end with the separator. |
| 2027 | (dolist (submatch (prog1 suball (setq suball ()))) |
| 2028 | (when (eq sep (aref submatch (1- (length submatch)))) |
| 2029 | (push submatch suball))) |
| 2030 | (when suball |
| 2031 | ;; Update the boundaries and corresponding pattern. |
| 2032 | ;; We assume that all submatches result in the same boundaries |
| 2033 | ;; since we wouldn't know how to merge them otherwise anyway. |
| 2034 | ;; FIXME: COMPLETE REWRITE!!! |
| 2035 | (let* ((newbeforepoint |
| 2036 | (concat subprefix (car suball) |
| 2037 | (substring string 0 relpoint))) |
| 2038 | (leftbound (+ (length subprefix) (length (car suball)))) |
| 2039 | (newbounds (completion-boundaries |
| 2040 | newbeforepoint table pred afterpoint))) |
| 2041 | (unless (or (and (eq (cdr bounds) (cdr newbounds)) |
| 2042 | (eq (car newbounds) leftbound)) |
| 2043 | ;; Refuse new boundaries if they step over |
| 2044 | ;; the submatch. |
| 2045 | (< (car newbounds) leftbound)) |
| 2046 | ;; The new completed prefix does change the boundaries |
| 2047 | ;; of the completed substring. |
| 2048 | (setq suffix (substring afterpoint (cdr newbounds))) |
| 2049 | (setq string |
| 2050 | (concat (substring newbeforepoint (car newbounds)) |
| 2051 | (substring afterpoint 0 (cdr newbounds)))) |
| 2052 | (setq between (substring newbeforepoint leftbound |
| 2053 | (car newbounds))) |
| 2054 | (setq pattern (completion-pcm--string->pattern |
| 2055 | string |
| 2056 | (- (length newbeforepoint) |
| 2057 | (car newbounds))))) |
| 2058 | (dolist (submatch suball) |
| 2059 | (setq all (nconc (mapcar |
| 2060 | (lambda (s) (concat submatch between s)) |
| 2061 | (funcall filter |
| 2062 | (completion-pcm--all-completions |
| 2063 | (concat subprefix submatch between) |
| 2064 | pattern table pred))) |
| 2065 | all))) |
| 2066 | ;; FIXME: This can come in handy for try-completion, |
| 2067 | ;; but isn't right for all-completions, since it lists |
| 2068 | ;; invalid completions. |
| 2069 | ;; (unless all |
| 2070 | ;; ;; Even though we found expansions in the prefix, none |
| 2071 | ;; ;; leads to a valid completion. |
| 2072 | ;; ;; Let's keep the expansions, tho. |
| 2073 | ;; (dolist (submatch suball) |
| 2074 | ;; (push (concat submatch between newsubstring) all))) |
| 2075 | )) |
| 2076 | (setq pattern (append subpat (list 'any (string sep)) |
| 2077 | (if between (list between)) pattern)) |
| 2078 | (setq prefix subprefix))))) |
| 2079 | (if (and (null all) firsterror) |
| 2080 | (signal (car firsterror) (cdr firsterror)) |
| 2081 | (list pattern all prefix suffix))))) |
| 2082 | |
| 2083 | (defun completion-pcm-all-completions (string table pred point) |
| 2084 | (destructuring-bind (pattern all &optional prefix suffix) |
| 2085 | (completion-pcm--find-all-completions string table pred point) |
| 2086 | (when all |
| 2087 | (nconc (completion-pcm--hilit-commonality pattern all) |
| 2088 | (length prefix))))) |
| 2089 | |
| 2090 | (defun completion--sreverse (str) |
| 2091 | "Like `reverse' but for a string STR rather than a list." |
| 2092 | (apply 'string (nreverse (mapcar 'identity str)))) |
| 2093 | |
| 2094 | (defun completion--common-suffix (strs) |
| 2095 | "Return the common suffix of the strings STRS." |
| 2096 | (completion--sreverse |
| 2097 | (try-completion |
| 2098 | "" |
| 2099 | (mapcar 'completion--sreverse strs)))) |
| 2100 | |
| 2101 | (defun completion-pcm--merge-completions (strs pattern) |
| 2102 | "Extract the commonality in STRS, with the help of PATTERN." |
| 2103 | ;; When completing while ignoring case, we want to try and avoid |
| 2104 | ;; completing "fo" to "foO" when completing against "FOO" (bug#4219). |
| 2105 | ;; So we try and make sure that the string we return is all made up |
| 2106 | ;; of text from the completions rather than part from the |
| 2107 | ;; completions and part from the input. |
| 2108 | ;; FIXME: This reduces the problems of inconsistent capitalization |
| 2109 | ;; but it doesn't fully fix it: we may still end up completing |
| 2110 | ;; "fo-ba" to "foo-BAR" or "FOO-bar" when completing against |
| 2111 | ;; '("foo-barr" "FOO-BARD"). |
| 2112 | (cond |
| 2113 | ((null (cdr strs)) (list (car strs))) |
| 2114 | (t |
| 2115 | (let ((re (completion-pcm--pattern->regex pattern 'group)) |
| 2116 | (ccs ())) ;Chopped completions. |
| 2117 | |
| 2118 | ;; First chop each string into the parts corresponding to each |
| 2119 | ;; non-constant element of `pattern', using regexp-matching. |
| 2120 | (let ((case-fold-search completion-ignore-case)) |
| 2121 | (dolist (str strs) |
| 2122 | (unless (string-match re str) |
| 2123 | (error "Internal error: %s doesn't match %s" str re)) |
| 2124 | (let ((chopped ()) |
| 2125 | (last 0) |
| 2126 | (i 1) |
| 2127 | next) |
| 2128 | (while (setq next (match-end i)) |
| 2129 | (push (substring str last next) chopped) |
| 2130 | (setq last next) |
| 2131 | (setq i (1+ i))) |
| 2132 | ;; Add the text corresponding to the implicit trailing `any'. |
| 2133 | (push (substring str last) chopped) |
| 2134 | (push (nreverse chopped) ccs)))) |
| 2135 | |
| 2136 | ;; Then for each of those non-constant elements, extract the |
| 2137 | ;; commonality between them. |
| 2138 | (let ((res ()) |
| 2139 | (fixed "")) |
| 2140 | ;; Make the implicit trailing `any' explicit. |
| 2141 | (dolist (elem (append pattern '(any))) |
| 2142 | (if (stringp elem) |
| 2143 | (setq fixed (concat fixed elem)) |
| 2144 | (let ((comps ())) |
| 2145 | (dolist (cc (prog1 ccs (setq ccs nil))) |
| 2146 | (push (car cc) comps) |
| 2147 | (push (cdr cc) ccs)) |
| 2148 | ;; Might improve the likelihood to avoid choosing |
| 2149 | ;; different capitalizations in different parts. |
| 2150 | ;; In practice, it doesn't seem to make any difference. |
| 2151 | (setq ccs (nreverse ccs)) |
| 2152 | (let* ((prefix (try-completion fixed comps)) |
| 2153 | (unique (or (and (eq prefix t) (setq prefix fixed)) |
| 2154 | (eq t (try-completion prefix comps))))) |
| 2155 | (unless (equal prefix "") (push prefix res)) |
| 2156 | ;; If there's only one completion, `elem' is not useful |
| 2157 | ;; any more: it can only match the empty string. |
| 2158 | ;; FIXME: in some cases, it may be necessary to turn an |
| 2159 | ;; `any' into a `star' because the surrounding context has |
| 2160 | ;; changed such that string->pattern wouldn't add an `any' |
| 2161 | ;; here any more. |
| 2162 | (unless unique |
| 2163 | (push elem res) |
| 2164 | (when (memq elem '(star point prefix)) |
| 2165 | ;; Extract common suffix additionally to common prefix. |
| 2166 | ;; Only do it for `point', `star', and `prefix' since for |
| 2167 | ;; `any' it could lead to a merged completion that |
| 2168 | ;; doesn't itself match the candidates. |
| 2169 | (let ((suffix (completion--common-suffix comps))) |
| 2170 | (assert (stringp suffix)) |
| 2171 | (unless (equal suffix "") |
| 2172 | (push suffix res))))) |
| 2173 | (setq fixed ""))))) |
| 2174 | ;; We return it in reverse order. |
| 2175 | res))))) |
| 2176 | |
| 2177 | (defun completion-pcm--pattern->string (pattern) |
| 2178 | (mapconcat (lambda (x) (cond |
| 2179 | ((stringp x) x) |
| 2180 | ((eq x 'star) "*") |
| 2181 | (t ""))) ;any, point, prefix. |
| 2182 | pattern |
| 2183 | "")) |
| 2184 | |
| 2185 | ;; We want to provide the functionality of `try', but we use `all' |
| 2186 | ;; and then merge it. In most cases, this works perfectly, but |
| 2187 | ;; if the completion table doesn't consider the same completions in |
| 2188 | ;; `try' as in `all', then we have a problem. The most common such |
| 2189 | ;; case is for filename completion where completion-ignored-extensions |
| 2190 | ;; is only obeyed by the `try' code. We paper over the difference |
| 2191 | ;; here. Note that it is not quite right either: if the completion |
| 2192 | ;; table uses completion-table-in-turn, this filtering may take place |
| 2193 | ;; too late to correctly fallback from the first to the |
| 2194 | ;; second alternative. |
| 2195 | (defun completion-pcm--filename-try-filter (all) |
| 2196 | "Filter to adjust `all' file completion to the behavior of `try'." |
| 2197 | (when all |
| 2198 | (let ((try ()) |
| 2199 | (re (concat "\\(?:\\`\\.\\.?/\\|" |
| 2200 | (regexp-opt completion-ignored-extensions) |
| 2201 | "\\)\\'"))) |
| 2202 | (dolist (f all) |
| 2203 | (unless (string-match-p re f) (push f try))) |
| 2204 | (or try all)))) |
| 2205 | |
| 2206 | |
| 2207 | (defun completion-pcm--merge-try (pattern all prefix suffix) |
| 2208 | (cond |
| 2209 | ((not (consp all)) all) |
| 2210 | ((and (not (consp (cdr all))) ;Only one completion. |
| 2211 | ;; Ignore completion-ignore-case here. |
| 2212 | (equal (completion-pcm--pattern->string pattern) (car all))) |
| 2213 | t) |
| 2214 | (t |
| 2215 | (let* ((mergedpat (completion-pcm--merge-completions all pattern)) |
| 2216 | ;; `mergedpat' is in reverse order. Place new point (by |
| 2217 | ;; order of preference) either at the old point, or at |
| 2218 | ;; the last place where there's something to choose, or |
| 2219 | ;; at the very end. |
| 2220 | (pointpat (or (memq 'point mergedpat) |
| 2221 | (memq 'any mergedpat) |
| 2222 | (memq 'star mergedpat) |
| 2223 | ;; Not `prefix'. |
| 2224 | mergedpat)) |
| 2225 | ;; New pos from the start. |
| 2226 | (newpos (length (completion-pcm--pattern->string pointpat))) |
| 2227 | ;; Do it afterwards because it changes `pointpat' by sideeffect. |
| 2228 | (merged (completion-pcm--pattern->string (nreverse mergedpat)))) |
| 2229 | |
| 2230 | (setq suffix (completion--merge-suffix merged newpos suffix)) |
| 2231 | (cons (concat prefix merged suffix) (+ newpos (length prefix))))))) |
| 2232 | |
| 2233 | (defun completion-pcm-try-completion (string table pred point) |
| 2234 | (destructuring-bind (pattern all prefix suffix) |
| 2235 | (completion-pcm--find-all-completions |
| 2236 | string table pred point |
| 2237 | (if minibuffer-completing-file-name |
| 2238 | 'completion-pcm--filename-try-filter)) |
| 2239 | (completion-pcm--merge-try pattern all prefix suffix))) |
| 2240 | |
| 2241 | ;;; Substring completion |
| 2242 | ;; Mostly derived from the code of `basic' completion. |
| 2243 | |
| 2244 | (defun completion-substring--all-completions (string table pred point) |
| 2245 | (let* ((beforepoint (substring string 0 point)) |
| 2246 | (afterpoint (substring string point)) |
| 2247 | (bounds (completion-boundaries beforepoint table pred afterpoint)) |
| 2248 | (suffix (substring afterpoint (cdr bounds))) |
| 2249 | (prefix (substring beforepoint 0 (car bounds))) |
| 2250 | (basic-pattern (completion-basic--pattern |
| 2251 | beforepoint afterpoint bounds)) |
| 2252 | (pattern (if (not (stringp (car basic-pattern))) |
| 2253 | basic-pattern |
| 2254 | (cons 'prefix basic-pattern))) |
| 2255 | (all (completion-pcm--all-completions prefix pattern table pred))) |
| 2256 | (list all pattern prefix suffix (car bounds)))) |
| 2257 | |
| 2258 | (defun completion-substring-try-completion (string table pred point) |
| 2259 | (destructuring-bind (all pattern prefix suffix carbounds) |
| 2260 | (completion-substring--all-completions string table pred point) |
| 2261 | (if minibuffer-completing-file-name |
| 2262 | (setq all (completion-pcm--filename-try-filter all))) |
| 2263 | (completion-pcm--merge-try pattern all prefix suffix))) |
| 2264 | |
| 2265 | (defun completion-substring-all-completions (string table pred point) |
| 2266 | (destructuring-bind (all pattern prefix suffix carbounds) |
| 2267 | (completion-substring--all-completions string table pred point) |
| 2268 | (when all |
| 2269 | (nconc (completion-pcm--hilit-commonality pattern all) |
| 2270 | (length prefix))))) |
| 2271 | |
| 2272 | ;; Initials completion |
| 2273 | ;; Complete /ums to /usr/monnier/src or lch to list-command-history. |
| 2274 | |
| 2275 | (defun completion-initials-expand (str table pred) |
| 2276 | (let ((bounds (completion-boundaries str table pred ""))) |
| 2277 | (unless (or (zerop (length str)) |
| 2278 | ;; Only check within the boundaries, since the |
| 2279 | ;; boundary char (e.g. /) might be in delim-regexp. |
| 2280 | (string-match completion-pcm--delim-wild-regex str |
| 2281 | (car bounds))) |
| 2282 | (if (zerop (car bounds)) |
| 2283 | (mapconcat 'string str "-") |
| 2284 | ;; If there's a boundary, it's trickier. The main use-case |
| 2285 | ;; we consider here is file-name completion. We'd like |
| 2286 | ;; to expand ~/eee to ~/e/e/e and /eee to /e/e/e. |
| 2287 | ;; But at the same time, we don't want /usr/share/ae to expand |
| 2288 | ;; to /usr/share/a/e just because we mistyped "ae" for "ar", |
| 2289 | ;; so we probably don't want initials to touch anything that |
| 2290 | ;; looks like /usr/share/foo. As a heuristic, we just check that |
| 2291 | ;; the text before the boundary char is at most 1 char. |
| 2292 | ;; This allows both ~/eee and /eee and not much more. |
| 2293 | ;; FIXME: It sadly also disallows the use of ~/eee when that's |
| 2294 | ;; embedded within something else (e.g. "(~/eee" in Info node |
| 2295 | ;; completion or "ancestor:/eee" in bzr-revision completion). |
| 2296 | (when (< (car bounds) 3) |
| 2297 | (let ((sep (substring str (1- (car bounds)) (car bounds)))) |
| 2298 | ;; FIXME: the above string-match checks the whole string, whereas |
| 2299 | ;; we end up only caring about the after-boundary part. |
| 2300 | (concat (substring str 0 (car bounds)) |
| 2301 | (mapconcat 'string (substring str (car bounds)) sep)))))))) |
| 2302 | |
| 2303 | (defun completion-initials-all-completions (string table pred point) |
| 2304 | (let ((newstr (completion-initials-expand string table pred))) |
| 2305 | (when newstr |
| 2306 | (completion-pcm-all-completions newstr table pred (length newstr))))) |
| 2307 | |
| 2308 | (defun completion-initials-try-completion (string table pred point) |
| 2309 | (let ((newstr (completion-initials-expand string table pred))) |
| 2310 | (when newstr |
| 2311 | (completion-pcm-try-completion newstr table pred (length newstr))))) |
| 2312 | |
| 2313 | \f |
| 2314 | ;; Miscellaneous |
| 2315 | |
| 2316 | (defun minibuffer-insert-file-name-at-point () |
| 2317 | "Get a file name at point in original buffer and insert it to minibuffer." |
| 2318 | (interactive) |
| 2319 | (let ((file-name-at-point |
| 2320 | (with-current-buffer (window-buffer (minibuffer-selected-window)) |
| 2321 | (run-hook-with-args-until-success 'file-name-at-point-functions)))) |
| 2322 | (when file-name-at-point |
| 2323 | (insert file-name-at-point)))) |
| 2324 | |
| 2325 | (provide 'minibuffer) |
| 2326 | |
| 2327 | ;;; minibuffer.el ends here |