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