LCOV - code coverage report
Current view: top level - lisp - minibuffer.el (source / functions) Hit Total Coverage
Test: tramp-tests-after.info Lines: 8 1464 0.5 %
Date: 2017-08-30 10:12:24 Functions: 4 149 2.7 %

          Line data    Source code
       1             : ;;; minibuffer.el --- Minibuffer completion functions -*- lexical-binding: t -*-
       2             : 
       3             : ;; Copyright (C) 2008-2017 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             : ;; - `metadata' in which case it should return (metadata . ALIST) where
      35             : ;;   ALIST is the metadata of this table.  See `completion-metadata'.
      36             : ;;   Any other return value should be ignored (so we ignore values returned
      37             : ;;   from completion tables that don't know about this new `action' form).
      38             : 
      39             : ;;; Bugs:
      40             : 
      41             : ;; - completion-all-sorted-completions lists all the completions, whereas
      42             : ;;   it should only lists the ones that `try-completion' would consider.
      43             : ;;   E.g.  it should honor completion-ignored-extensions.
      44             : ;; - choose-completion can't automatically figure out the boundaries
      45             : ;;   corresponding to the displayed completions because we only
      46             : ;;   provide the start info but not the end info in
      47             : ;;   completion-base-position.
      48             : ;; - C-x C-f ~/*/sr ? should not list "~/./src".
      49             : ;; - minibuffer-force-complete completes ~/src/emacs/t<!>/lisp/minibuffer.el
      50             : ;;   to ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
      51             : 
      52             : ;;; Todo:
      53             : 
      54             : ;; - Make *Completions* readable even if some of the completion
      55             : ;;   entries have LF chars or spaces in them (including at
      56             : ;;   beginning/end) or are very long.
      57             : ;; - for M-x, cycle-sort commands that have no key binding first.
      58             : ;; - Make things like icomplete-mode or lightning-completion work with
      59             : ;;   completion-in-region-mode.
      60             : ;; - extend `metadata':
      61             : ;;   - indicate how to turn all-completion's output into
      62             : ;;     try-completion's output: e.g. completion-ignored-extensions.
      63             : ;;     maybe that could be merged with the "quote" operation.
      64             : ;;   - indicate that `all-completions' doesn't do prefix-completion
      65             : ;;     but just returns some list that relates in some other way to
      66             : ;;     the provided string (as is the case in filecache.el), in which
      67             : ;;     case partial-completion (for example) doesn't make any sense
      68             : ;;     and neither does the completions-first-difference highlight.
      69             : ;;   - indicate how to display the completions in *Completions* (turn
      70             : ;;     \n into something else, add special boundaries between
      71             : ;;     completions).  E.g. when completing from the kill-ring.
      72             : 
      73             : ;; - case-sensitivity currently confuses two issues:
      74             : ;;   - whether or not a particular completion table should be case-sensitive
      75             : ;;     (i.e. whether strings that differ only by case are semantically
      76             : ;;     equivalent)
      77             : ;;   - whether the user wants completion to pay attention to case.
      78             : ;;   e.g. we may want to make it possible for the user to say "first try
      79             : ;;   completion case-sensitively, and if that fails, try to ignore case".
      80             : ;;   Maybe the trick is that we should distinguish completion-ignore-case in
      81             : ;;   try/all-completions (obey user's preference) from its use in
      82             : ;;   test-completion (obey the underlying object's semantics).
      83             : 
      84             : ;; - add support for ** to pcm.
      85             : ;; - Add vc-file-name-completion-table to read-file-name-internal.
      86             : ;; - A feature like completing-help.el.
      87             : 
      88             : ;;; Code:
      89             : 
      90             : (eval-when-compile (require 'cl-lib))
      91             : 
      92             : ;;; Completion table manipulation
      93             : 
      94             : ;; New completion-table operation.
      95             : (defun completion-boundaries (string collection pred suffix)
      96             :   "Return the boundaries of text on which COLLECTION will operate.
      97             : STRING is the string on which completion will be performed.
      98             : SUFFIX is the string after point.
      99             : If COLLECTION is a function, it is called with 3 arguments: STRING,
     100             : PRED, and a cons cell of the form (boundaries . SUFFIX).
     101             : 
     102             : The result is of the form (START . END) where START is the position
     103             : in STRING of the beginning of the completion field and END is the position
     104             : in SUFFIX of the end of the completion field.
     105             : E.g. for simple completion tables, the result is always (0 . (length SUFFIX))
     106             : and for file names the result is the positions delimited by
     107             : the closest directory separators."
     108           0 :   (let ((boundaries (if (functionp collection)
     109           0 :                         (funcall collection string pred
     110           0 :                                  (cons 'boundaries suffix)))))
     111           0 :     (if (not (eq (car-safe boundaries) 'boundaries))
     112           0 :         (setq boundaries nil))
     113           0 :     (cons (or (cadr boundaries) 0)
     114           0 :           (or (cddr boundaries) (length suffix)))))
     115             : 
     116             : (defun completion-metadata (string table pred)
     117             :   "Return the metadata of elements to complete at the end of STRING.
     118             : This metadata is an alist.  Currently understood keys are:
     119             : - `category': the kind of objects returned by `all-completions'.
     120             :    Used by `completion-category-overrides'.
     121             : - `annotation-function': function to add annotations in *Completions*.
     122             :    Takes one argument (STRING), which is a possible completion and
     123             :    returns a string to append to STRING.
     124             : - `display-sort-function': function to sort entries in *Completions*.
     125             :    Takes one argument (COMPLETIONS) and should return a new list
     126             :    of completions.  Can operate destructively.
     127             : - `cycle-sort-function': function to sort entries when cycling.
     128             :    Works like `display-sort-function'.
     129             : The metadata of a completion table should be constant between two boundaries."
     130           0 :   (let ((metadata (if (functionp table)
     131           0 :                       (funcall table string pred 'metadata))))
     132           0 :     (if (eq (car-safe metadata) 'metadata)
     133           0 :         metadata
     134           0 :       '(metadata))))
     135             : 
     136             : (defun completion--field-metadata (field-start)
     137           0 :   (completion-metadata (buffer-substring-no-properties field-start (point))
     138           0 :                        minibuffer-completion-table
     139           0 :                        minibuffer-completion-predicate))
     140             : 
     141             : (defun completion-metadata-get (metadata prop)
     142           0 :   (cdr (assq prop metadata)))
     143             : 
     144             : (defun completion--some (fun xs)
     145             :   "Apply FUN to each element of XS in turn.
     146             : Return the first non-nil returned value.
     147             : Like CL's `some'."
     148           0 :   (let ((firsterror nil)
     149             :         res)
     150           0 :     (while (and (not res) xs)
     151           0 :       (condition-case-unless-debug err
     152           0 :           (setq res (funcall fun (pop xs)))
     153           0 :         (error (unless firsterror (setq firsterror err)) nil)))
     154           0 :     (or res
     155           0 :         (if firsterror (signal (car firsterror) (cdr firsterror))))))
     156             : 
     157             : (defun complete-with-action (action table string pred)
     158             :   "Perform completion ACTION.
     159             : STRING is the string to complete.
     160             : TABLE is the completion table.
     161             : PRED is a completion predicate.
     162             : ACTION can be one of nil, t or `lambda'."
     163           0 :   (cond
     164           0 :    ((functionp table) (funcall table string pred action))
     165           0 :    ((eq (car-safe action) 'boundaries) nil)
     166           0 :    ((eq action 'metadata) nil)
     167             :    (t
     168           0 :     (funcall
     169           0 :      (cond
     170           0 :       ((null action) 'try-completion)
     171           0 :       ((eq action t) 'all-completions)
     172           0 :       (t 'test-completion))
     173           0 :      string table pred))))
     174             : 
     175             : (defun completion-table-dynamic (fun &optional switch-buffer)
     176             :   "Use function FUN as a dynamic completion table.
     177             : FUN is called with one argument, the string for which completion is required,
     178             : and it should return an alist containing all the intended possible completions.
     179             : This alist may be a full list of possible completions so that FUN can ignore
     180             : the value of its argument.
     181             : If SWITCH-BUFFER is non-nil and completion is performed in the
     182             : minibuffer, FUN will be called in the buffer from which the minibuffer
     183             : was entered.
     184             : 
     185             : The result of the `completion-table-dynamic' form is a function
     186             : that can be used as the COLLECTION argument to `try-completion' and
     187             : `all-completions'.  See Info node `(elisp)Programmed Completion'.
     188             : 
     189             : See also the related function `completion-table-with-cache'."
     190             :   (lambda (string pred action)
     191           0 :     (if (or (eq (car-safe action) 'boundaries) (eq action 'metadata))
     192             :         ;; `fun' is not supposed to return another function but a plain old
     193             :         ;; completion table, whose boundaries are always trivial.
     194             :         nil
     195           0 :       (with-current-buffer (if (not switch-buffer) (current-buffer)
     196           0 :                              (let ((win (minibuffer-selected-window)))
     197           0 :                                (if (window-live-p win) (window-buffer win)
     198           0 :                                  (current-buffer))))
     199           0 :         (complete-with-action action (funcall fun string) string pred)))))
     200             : 
     201             : (defun completion-table-with-cache (fun &optional ignore-case)
     202             :   "Create dynamic completion table from function FUN, with cache.
     203             : This is a wrapper for `completion-table-dynamic' that saves the last
     204             : argument-result pair from FUN, so that several lookups with the
     205             : same argument (or with an argument that starts with the first one)
     206             : only need to call FUN once.  This can be useful when FUN performs a
     207             : relatively slow operation, such as calling an external process.
     208             : 
     209             : When IGNORE-CASE is non-nil, FUN is expected to be case-insensitive."
     210             :   ;; See eg bug#11906.
     211           0 :   (let* (last-arg last-result
     212             :          (new-fun
     213             :           (lambda (arg)
     214           0 :             (if (and last-arg (string-prefix-p last-arg arg ignore-case))
     215           0 :                 last-result
     216           0 :               (prog1
     217           0 :                   (setq last-result (funcall fun arg))
     218           0 :                 (setq last-arg arg))))))
     219           0 :     (completion-table-dynamic new-fun)))
     220             : 
     221             : (defmacro lazy-completion-table (var fun)
     222             :   "Initialize variable VAR as a lazy completion table.
     223             : If the completion table VAR is used for the first time (e.g., by passing VAR
     224             : as an argument to `try-completion'), the function FUN is called with no
     225             : arguments.  FUN must return the completion table that will be stored in VAR.
     226             : If completion is requested in the minibuffer, FUN will be called in the buffer
     227             : from which the minibuffer was entered.  The return value of
     228             : `lazy-completion-table' must be used to initialize the value of VAR.
     229             : 
     230             : You should give VAR a non-nil `risky-local-variable' property."
     231             :   (declare (debug (symbolp lambda-expr)))
     232           1 :   (let ((str (make-symbol "string")))
     233           1 :     `(completion-table-dynamic
     234           1 :       (lambda (,str)
     235           1 :         (when (functionp ,var)
     236           1 :           (setq ,var (funcall #',fun)))
     237           1 :         ,var)
     238           1 :       'do-switch-buffer)))
     239             : 
     240             : (defun completion-table-case-fold (table &optional dont-fold)
     241             :   "Return new completion TABLE that is case insensitive.
     242             : If DONT-FOLD is non-nil, return a completion table that is
     243             : case sensitive instead."
     244             :   (lambda (string pred action)
     245           0 :     (let ((completion-ignore-case (not dont-fold)))
     246           0 :       (complete-with-action action table string pred))))
     247             : 
     248             : (defun completion-table-subvert (table s1 s2)
     249             :   "Return a completion table from TABLE with S1 replaced by S2.
     250             : The result is a completion table which completes strings of the
     251             : form (concat S1 S) in the same way as TABLE completes strings of
     252             : the form (concat S2 S)."
     253             :   (lambda (string pred action)
     254           0 :     (let* ((str (if (string-prefix-p s1 string completion-ignore-case)
     255           0 :                     (concat s2 (substring string (length s1)))))
     256           0 :            (res (if str (complete-with-action action table str pred))))
     257           0 :       (when res
     258           0 :         (cond
     259           0 :          ((eq (car-safe action) 'boundaries)
     260           0 :           (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0)))
     261           0 :             `(boundaries
     262           0 :               ,(max (length s1)
     263           0 :                     (+ beg (- (length s1) (length s2))))
     264           0 :               . ,(and (eq (car-safe res) 'boundaries) (cddr res)))))
     265           0 :          ((stringp res)
     266           0 :           (if (string-prefix-p s2 string completion-ignore-case)
     267           0 :               (concat s1 (substring res (length s2)))))
     268           0 :          ((eq action t)
     269           0 :           (let ((bounds (completion-boundaries str table pred "")))
     270           0 :             (if (>= (car bounds) (length s2))
     271           0 :                 res
     272           0 :               (let ((re (concat "\\`"
     273           0 :                                 (regexp-quote (substring s2 (car bounds))))))
     274           0 :                 (delq nil
     275           0 :                       (mapcar (lambda (c)
     276           0 :                                 (if (string-match re c)
     277           0 :                                     (substring c (match-end 0))))
     278           0 :                               res))))))
     279             :          ;; E.g. action=nil and it's the only completion.
     280           0 :          (res))))))
     281             : 
     282             : (defun completion-table-with-context (prefix table string pred action)
     283             :   ;; TODO: add `suffix' maybe?
     284           0 :   (let ((pred
     285           0 :          (if (not (functionp pred))
     286             :              ;; Notice that `pred' may not be a function in some abusive cases.
     287           0 :              pred
     288             :            ;; Predicates are called differently depending on the nature of
     289             :            ;; the completion table :-(
     290           0 :            (cond
     291           0 :             ((vectorp table)            ;Obarray.
     292           0 :              (lambda (sym) (funcall pred (concat prefix (symbol-name sym)))))
     293           0 :             ((hash-table-p table)
     294           0 :              (lambda (s _v) (funcall pred (concat prefix s))))
     295           0 :             ((functionp table)
     296           0 :              (lambda (s) (funcall pred (concat prefix s))))
     297             :             (t                          ;Lists and alists.
     298             :              (lambda (s)
     299           0 :                (funcall pred (concat prefix (if (consp s) (car s) s)))))))))
     300           0 :     (if (eq (car-safe action) 'boundaries)
     301           0 :         (let* ((len (length prefix))
     302           0 :                (bound (completion-boundaries string table pred (cdr action))))
     303           0 :           `(boundaries ,(+ (car bound) len) . ,(cdr bound)))
     304           0 :       (let ((comp (complete-with-action action table string pred)))
     305           0 :         (cond
     306             :          ;; In case of try-completion, add the prefix.
     307           0 :          ((stringp comp) (concat prefix comp))
     308           0 :          (t comp))))))
     309             : 
     310             : (defun completion-table-with-terminator (terminator table string pred action)
     311             :   "Construct a completion table like TABLE but with an extra TERMINATOR.
     312             : This is meant to be called in a curried way by first passing TERMINATOR
     313             : and TABLE only (via `apply-partially').
     314             : TABLE is a completion table, and TERMINATOR is a string appended to TABLE's
     315             : completion if it is complete.  TERMINATOR is also used to determine the
     316             : completion suffix's boundary.
     317             : TERMINATOR can also be a cons cell (TERMINATOR . TERMINATOR-REGEXP)
     318             : in which case TERMINATOR-REGEXP is a regular expression whose submatch
     319             : number 1 should match TERMINATOR.  This is used when there is a need to
     320             : distinguish occurrences of the TERMINATOR strings which are really terminators
     321             : from others (e.g. escaped).  In this form, the car of TERMINATOR can also be,
     322             : instead of a string, a function that takes the completion and returns the
     323             : \"terminated\" string."
     324             :   ;; FIXME: This implementation is not right since it only adds the terminator
     325             :   ;; in try-completion, so any completion-style that builds the completion via
     326             :   ;; all-completions won't get the terminator, and selecting an entry in
     327             :   ;; *Completions* won't get the terminator added either.
     328           0 :   (cond
     329           0 :    ((eq (car-safe action) 'boundaries)
     330           0 :     (let* ((suffix (cdr action))
     331           0 :            (bounds (completion-boundaries string table pred suffix))
     332           0 :            (terminator-regexp (if (consp terminator)
     333           0 :                                   (cdr terminator) (regexp-quote terminator)))
     334           0 :            (max (and terminator-regexp
     335           0 :                      (string-match terminator-regexp suffix))))
     336           0 :       `(boundaries ,(car bounds)
     337           0 :                    . ,(min (cdr bounds) (or max (length suffix))))))
     338           0 :    ((eq action nil)
     339           0 :     (let ((comp (try-completion string table pred)))
     340           0 :       (if (consp terminator) (setq terminator (car terminator)))
     341           0 :       (if (eq comp t)
     342           0 :           (if (functionp terminator)
     343           0 :               (funcall terminator string)
     344           0 :             (concat string terminator))
     345           0 :         (if (and (stringp comp) (not (zerop (length comp)))
     346             :                  ;; Try to avoid the second call to try-completion, since
     347             :                  ;; it may be very inefficient (because `comp' made us
     348             :                  ;; jump to a new boundary, so we complete in that
     349             :                  ;; boundary with an empty start string).
     350           0 :                  (let ((newbounds (completion-boundaries comp table pred "")))
     351           0 :                    (< (car newbounds) (length comp)))
     352           0 :                  (eq (try-completion comp table pred) t))
     353           0 :             (if (functionp terminator)
     354           0 :                 (funcall terminator comp)
     355           0 :               (concat comp terminator))
     356           0 :           comp))))
     357             :    ;; completion-table-with-terminator is always used for
     358             :    ;; "sub-completions" so it's only called if the terminator is missing,
     359             :    ;; in which case `test-completion' should return nil.
     360           0 :    ((eq action 'lambda) nil)
     361             :    (t
     362             :     ;; FIXME: We generally want the `try' and `all' behaviors to be
     363             :     ;; consistent so pcm can merge the `all' output to get the `try' output,
     364             :     ;; but that sometimes clashes with the need for `all' output to look
     365             :     ;; good in *Completions*.
     366             :     ;; (mapcar (lambda (s) (concat s terminator))
     367             :     ;;         (all-completions string table pred))))
     368           0 :     (complete-with-action action table string pred))))
     369             : 
     370             : (defun completion-table-with-predicate (table pred1 strict string pred2 action)
     371             :   "Make a completion table equivalent to TABLE but filtered through PRED1.
     372             : PRED1 is a function of one argument which returns non-nil if and
     373             : only if the argument is an element of TABLE which should be
     374             : considered for completion.  STRING, PRED2, and ACTION are the
     375             : usual arguments to completion tables, as described in
     376             : `try-completion', `all-completions', and `test-completion'.  If
     377             : STRICT is non-nil, the predicate always applies; if nil it only
     378             : applies if it does not reduce the set of possible completions to
     379             : nothing.  Note: TABLE needs to be a proper completion table which
     380             : obeys predicates."
     381           0 :   (cond
     382           0 :    ((and (not strict) (eq action 'lambda))
     383             :     ;; Ignore pred1 since it doesn't really have to apply anyway.
     384           0 :     (test-completion string table pred2))
     385             :    (t
     386           0 :     (or (complete-with-action action table string
     387           0 :                               (if (not (and pred1 pred2))
     388           0 :                                   (or pred1 pred2)
     389             :                                 (lambda (x)
     390             :                                   ;; Call `pred1' first, so that `pred2'
     391             :                                   ;; really can't tell that `x' is in table.
     392           0 :                                   (and (funcall pred1 x) (funcall pred2 x)))))
     393             :         ;; If completion failed and we're not applying pred1 strictly, try
     394             :         ;; again without pred1.
     395           0 :         (and (not strict) pred1 pred2
     396           0 :              (complete-with-action action table string pred2))))))
     397             : 
     398             : (defun completion-table-in-turn (&rest tables)
     399             :   "Create a completion table that tries each table in TABLES in turn."
     400             :   ;; FIXME: the boundaries may come from TABLE1 even when the completion list
     401             :   ;; is returned by TABLE2 (because TABLE1 returned an empty list).
     402             :   ;; Same potential problem if any of the tables use quoting.
     403             :   (lambda (string pred action)
     404           0 :     (completion--some (lambda (table)
     405           0 :                         (complete-with-action action table string pred))
     406           0 :                       tables)))
     407             : 
     408             : (defun completion-table-merge (&rest tables)
     409             :   "Create a completion table that collects completions from all TABLES."
     410             :   ;; FIXME: same caveats as in `completion-table-in-turn'.
     411             :   (lambda (string pred action)
     412           0 :     (cond
     413           0 :      ((null action)
     414           0 :       (let ((retvals (mapcar (lambda (table)
     415           0 :                                (try-completion string table pred))
     416           0 :                              tables)))
     417           0 :         (if (member string retvals)
     418           0 :             string
     419           0 :           (try-completion string
     420           0 :                           (mapcar (lambda (value)
     421           0 :                                     (if (eq value t) string value))
     422           0 :                                   (delq nil retvals))
     423           0 :                           pred))))
     424           0 :      ((eq action t)
     425           0 :       (apply #'append (mapcar (lambda (table)
     426           0 :                                 (all-completions string table pred))
     427           0 :                               tables)))
     428             :      (t
     429           0 :       (completion--some (lambda (table)
     430           0 :                           (complete-with-action action table string pred))
     431           0 :                         tables)))))
     432             : 
     433             : (defun completion-table-with-quoting (table unquote requote)
     434             :   ;; A difficult part of completion-with-quoting is to map positions in the
     435             :   ;; quoted string to equivalent positions in the unquoted string and
     436             :   ;; vice-versa.  There is no efficient and reliable algorithm that works for
     437             :   ;; arbitrary quote and unquote functions.
     438             :   ;; So to map from quoted positions to unquoted positions, we simply assume
     439             :   ;; that `concat' and `unquote' commute (which tends to be the case).
     440             :   ;; And we ask `requote' to do the work of mapping from unquoted positions
     441             :   ;; back to quoted positions.
     442             :   ;; FIXME: For some forms of "quoting" such as the truncation behavior of
     443             :   ;; substitute-in-file-name, it would be desirable not to requote completely.
     444             :   "Return a new completion table operating on quoted text.
     445             : TABLE operates on the unquoted text.
     446             : UNQUOTE is a function that takes a string and returns a new unquoted string.
     447             : REQUOTE is a function of 2 args (UPOS QSTR) where
     448             :   QSTR is a string entered by the user (and hence indicating
     449             :   the user's preferred form of quoting); and
     450             :   UPOS is a position within the unquoted form of QSTR.
     451             : REQUOTE should return a pair (QPOS . QFUN) such that QPOS is the
     452             : position corresponding to UPOS but in QSTR, and QFUN is a function
     453             : of one argument (a string) which returns that argument appropriately quoted
     454             : for use at QPOS."
     455             :   ;; FIXME: One problem with the current setup is that `qfun' doesn't know if
     456             :   ;; its argument is "the end of the completion", so if the quoting used double
     457             :   ;; quotes (for example), we end up completing "fo" to "foobar and throwing
     458             :   ;; away the closing double quote.
     459             :   (lambda (string pred action)
     460           0 :     (cond
     461           0 :      ((eq action 'metadata)
     462           0 :       (append (completion-metadata string table pred)
     463           0 :               '((completion--unquote-requote . t))))
     464             : 
     465           0 :      ((eq action 'lambda) ;;test-completion
     466           0 :       (let ((ustring (funcall unquote string)))
     467           0 :         (test-completion ustring table pred)))
     468             : 
     469           0 :      ((eq (car-safe action) 'boundaries)
     470           0 :       (let* ((ustring (funcall unquote string))
     471           0 :              (qsuffix (cdr action))
     472           0 :              (ufull (if (zerop (length qsuffix)) ustring
     473           0 :                       (funcall unquote (concat string qsuffix))))
     474           0 :              (_ (cl-assert (string-prefix-p ustring ufull)))
     475           0 :              (usuffix (substring ufull (length ustring)))
     476           0 :              (boundaries (completion-boundaries ustring table pred usuffix))
     477           0 :              (qlboundary (car (funcall requote (car boundaries) string)))
     478           0 :              (qrboundary (if (zerop (cdr boundaries)) 0 ;Common case.
     479           0 :                            (let* ((urfullboundary
     480           0 :                                    (+ (cdr boundaries) (length ustring))))
     481           0 :                              (- (car (funcall requote urfullboundary
     482           0 :                                               (concat string qsuffix)))
     483           0 :                                 (length string))))))
     484           0 :         `(boundaries ,qlboundary . ,qrboundary)))
     485             : 
     486             :      ;; In "normal" use a c-t-with-quoting completion table should never be
     487             :      ;; called with action in (t nil) because `completion--unquote' should have
     488             :      ;; been called before and would have returned a different completion table
     489             :      ;; to apply to the unquoted text.  But there's still a lot of code around
     490             :      ;; that likes to use all/try-completions directly, so we do our best to
     491             :      ;; handle those calls as well as we can.
     492             : 
     493           0 :      ((eq action nil) ;;try-completion
     494           0 :       (let* ((ustring (funcall unquote string))
     495           0 :              (completion (try-completion ustring table pred)))
     496             :         ;; Most forms of quoting allow several ways to quote the same string.
     497             :         ;; So here we could simply requote `completion' in a kind of
     498             :         ;; "canonical" quoted form without paying attention to the way
     499             :         ;; `string' was quoted.  But since we have to solve the more complex
     500             :         ;; problems of "pay attention to the original quoting" for
     501             :         ;; all-completions, we may as well use it here, since it provides
     502             :         ;; a nicer behavior.
     503           0 :         (if (not (stringp completion)) completion
     504           0 :           (car (completion--twq-try
     505           0 :                 string ustring completion 0 unquote requote)))))
     506             : 
     507           0 :      ((eq action t) ;;all-completions
     508             :       ;; When all-completions is used for completion-try/all-completions
     509             :       ;; (e.g. for `pcm' style), we can't do the job properly here because
     510             :       ;; the caller will match our output against some pattern derived from
     511             :       ;; the user's (quoted) input, and we don't have access to that
     512             :       ;; pattern, so we can't know how to requote our output so that it
     513             :       ;; matches the quoting used in the pattern.  It is to fix this
     514             :       ;; fundamental problem that we have to introduce the new
     515             :       ;; unquote-requote method so that completion-try/all-completions can
     516             :       ;; pass the unquoted string to the style functions.
     517           0 :       (pcase-let*
     518           0 :           ((ustring (funcall unquote string))
     519           0 :            (completions (all-completions ustring table pred))
     520           0 :            (boundary (car (completion-boundaries ustring table pred "")))
     521             :            (completions
     522           0 :             (completion--twq-all
     523           0 :              string ustring completions boundary unquote requote))
     524           0 :            (last (last completions)))
     525           0 :         (when (consp last) (setcdr last nil))
     526           0 :         completions))
     527             : 
     528           0 :      ((eq action 'completion--unquote)
     529             :       ;; PRED is really a POINT in STRING.
     530             :       ;; We should return a new set (STRING TABLE POINT REQUOTE)
     531             :       ;; where STRING is a new (unquoted) STRING to match against the new TABLE
     532             :       ;; using a new POINT inside it, and REQUOTE is a requoting function which
     533             :       ;; should reverse the unquoting, (i.e. it receives the completion result
     534             :       ;; of using the new TABLE and should turn it into the corresponding
     535             :       ;; quoted result).
     536           0 :       (let* ((qpos pred)
     537           0 :              (ustring (funcall unquote string))
     538           0 :              (uprefix (funcall unquote (substring string 0 qpos)))
     539             :              ;; FIXME: we really should pass `qpos' to `unquote' and have that
     540             :              ;; function give us the corresponding `uqpos'.  But for now we
     541             :              ;; presume (more or less) that `concat' and `unquote' commute.
     542           0 :              (uqpos (if (string-prefix-p uprefix ustring)
     543             :                         ;; Yay!!  They do seem to commute!
     544           0 :                         (length uprefix)
     545             :                       ;; They don't commute this time!  :-(
     546             :                       ;; Maybe qpos is in some text that disappears in the
     547             :                       ;; ustring (bug#17239).  Let's try a second chance guess.
     548           0 :                       (let ((usuffix (funcall unquote (substring string qpos))))
     549           0 :                         (if (string-suffix-p usuffix ustring)
     550             :                             ;; Yay!!  They still "commute" in a sense!
     551           0 :                             (- (length ustring) (length usuffix))
     552             :                           ;; Still no luck!  Let's just choose *some* position
     553             :                           ;; within ustring.
     554           0 :                           (/ (+ (min (length uprefix) (length ustring))
     555           0 :                                 (max (- (length ustring) (length usuffix)) 0))
     556           0 :                              2))))))
     557           0 :         (list ustring table uqpos
     558             :               (lambda (unquoted-result op)
     559           0 :                 (pcase op
     560             :                   (1 ;;try
     561           0 :                    (if (not (stringp (car-safe unquoted-result)))
     562           0 :                        unquoted-result
     563           0 :                      (completion--twq-try
     564           0 :                       string ustring
     565           0 :                       (car unquoted-result) (cdr unquoted-result)
     566           0 :                       unquote requote)))
     567             :                   (2 ;;all
     568           0 :                    (let* ((last (last unquoted-result))
     569           0 :                           (base (or (cdr last) 0)))
     570           0 :                      (when last
     571           0 :                        (setcdr last nil)
     572           0 :                        (completion--twq-all string ustring
     573           0 :                                             unquoted-result base
     574           0 :                                             unquote requote))))))))))))
     575             : 
     576             : (defun completion--twq-try (string ustring completion point
     577             :                                    unquote requote)
     578             :   ;; Basically two cases: either the new result is
     579             :   ;; - commonprefix1 <point> morecommonprefix <qpos> suffix
     580             :   ;; - commonprefix <qpos> newprefix <point> suffix
     581           0 :   (pcase-let*
     582           0 :       ((prefix (fill-common-string-prefix ustring completion))
     583           0 :        (suffix (substring completion (max point (length prefix))))
     584           0 :        (`(,qpos . ,qfun) (funcall requote (length prefix) string))
     585           0 :        (qstr1 (if (> point (length prefix))
     586           0 :                   (funcall qfun (substring completion (length prefix) point))))
     587           0 :        (qsuffix (funcall qfun suffix))
     588           0 :        (qstring (concat (substring string 0 qpos) qstr1 qsuffix))
     589             :        (qpoint
     590           0 :         (cond
     591           0 :          ((zerop point) 0)
     592           0 :          ((> point (length prefix)) (+ qpos (length qstr1)))
     593           0 :          (t (car (funcall requote point string))))))
     594             :     ;; Make sure `requote' worked.
     595           0 :     (if (equal (funcall unquote qstring) completion)
     596           0 :         (cons qstring qpoint)
     597             :       ;; If requote failed (e.g. because sifn-requote did not handle
     598             :       ;; Tramp's "/foo:/bar//baz -> /foo:/baz" truncation), then at least
     599             :       ;; try requote properly.
     600           0 :       (let ((qstr (funcall qfun completion)))
     601           0 :         (cons qstr (length qstr))))))
     602             : 
     603             : (defun completion--string-equal-p (s1 s2)
     604           0 :   (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case)))
     605             : 
     606             : (defun completion--twq-all (string ustring completions boundary
     607             :                                    _unquote requote)
     608           0 :   (when completions
     609           0 :     (pcase-let*
     610             :         ((prefix
     611           0 :           (let ((completion-regexp-list nil))
     612           0 :             (try-completion "" (cons (substring ustring boundary)
     613           0 :                                      completions))))
     614             :          (`(,qfullpos . ,qfun)
     615           0 :           (funcall requote (+ boundary (length prefix)) string))
     616           0 :          (qfullprefix (substring string 0 qfullpos))
     617             :          ;; FIXME: This assertion can be wrong, e.g. in Cygwin, where
     618             :          ;; (unquote "c:\bin") => "/usr/bin" but (unquote "c:\") => "/".
     619             :          ;;(cl-assert (completion--string-equal-p
     620             :          ;;            (funcall unquote qfullprefix)
     621             :          ;;            (concat (substring ustring 0 boundary) prefix))
     622             :          ;;           t))
     623           0 :          (qboundary (car (funcall requote boundary string)))
     624           0 :          (_ (cl-assert (<= qboundary qfullpos)))
     625             :          ;; FIXME: this split/quote/concat business messes up the carefully
     626             :          ;; placed completions-common-part and completions-first-difference
     627             :          ;; faces.  We could try within the mapcar loop to search for the
     628             :          ;; boundaries of those faces, pass them to `requote' to find their
     629             :          ;; equivalent positions in the quoted output and re-add the faces:
     630             :          ;; this might actually lead to correct results but would be
     631             :          ;; pretty expensive.
     632             :          ;; The better solution is to not quote the *Completions* display,
     633             :          ;; which nicely circumvents the problem.  The solution I used here
     634             :          ;; instead is to hope that `qfun' preserves the text-properties and
     635             :          ;; presume that the `first-difference' is not within the `prefix';
     636             :          ;; this presumption is not always true, but at least in practice it is
     637             :          ;; true in most cases.
     638           0 :          (qprefix (propertize (substring qfullprefix qboundary)
     639           0 :                               'face 'completions-common-part)))
     640             : 
     641             :       ;; Here we choose to quote all elements returned, but a better option
     642             :       ;; would be to return unquoted elements together with a function to
     643             :       ;; requote them, so that *Completions* can show nicer unquoted values
     644             :       ;; which only get quoted when needed by choose-completion.
     645           0 :       (nconc
     646           0 :        (mapcar (lambda (completion)
     647           0 :                  (cl-assert (string-prefix-p prefix completion 'ignore-case) t)
     648           0 :                  (let* ((new (substring completion (length prefix)))
     649           0 :                         (qnew (funcall qfun new))
     650             :                         (qprefix
     651           0 :                          (if (not completion-ignore-case)
     652           0 :                              qprefix
     653             :                            ;; Make qprefix inherit the case from `completion'.
     654           0 :                            (let* ((rest (substring completion
     655           0 :                                                    0 (length prefix)))
     656           0 :                                   (qrest (funcall qfun rest)))
     657           0 :                              (if (completion--string-equal-p qprefix qrest)
     658           0 :                                  (propertize qrest 'face
     659           0 :                                              'completions-common-part)
     660           0 :                                qprefix))))
     661           0 :                         (qcompletion (concat qprefix qnew)))
     662             :                    ;; FIXME: Similarly here, Cygwin's mapping trips this
     663             :                    ;; assertion.
     664             :                    ;;(cl-assert
     665             :                    ;; (completion--string-equal-p
     666             :                    ;;  (funcall unquote
     667             :                    ;;           (concat (substring string 0 qboundary)
     668             :                    ;;                   qcompletion))
     669             :                    ;;  (concat (substring ustring 0 boundary)
     670             :                    ;;          completion))
     671             :                    ;; t)
     672           0 :                    qcompletion))
     673           0 :                completions)
     674           0 :        qboundary))))
     675             : 
     676             : ;; (defmacro complete-in-turn (a b) `(completion-table-in-turn ,a ,b))
     677             : ;; (defmacro dynamic-completion-table (fun) `(completion-table-dynamic ,fun))
     678             : (define-obsolete-function-alias
     679             :   'complete-in-turn 'completion-table-in-turn "23.1")
     680             : (define-obsolete-function-alias
     681             :   'dynamic-completion-table 'completion-table-dynamic "23.1")
     682             : 
     683             : ;;; Minibuffer completion
     684             : 
     685             : (defgroup minibuffer nil
     686             :   "Controlling the behavior of the minibuffer."
     687             :   :link '(custom-manual "(emacs)Minibuffer")
     688             :   :group 'environment)
     689             : 
     690             : (defun minibuffer-message (message &rest args)
     691             :   "Temporarily display MESSAGE at the end of the minibuffer.
     692             : The text is displayed for `minibuffer-message-timeout' seconds,
     693             : or until the next input event arrives, whichever comes first.
     694             : Enclose MESSAGE in [...] if this is not yet the case.
     695             : If ARGS are provided, then pass MESSAGE through `format-message'."
     696           0 :   (if (not (minibufferp (current-buffer)))
     697           0 :       (progn
     698           0 :         (if args
     699           0 :             (apply 'message message args)
     700           0 :           (message "%s" message))
     701           0 :         (prog1 (sit-for (or minibuffer-message-timeout 1000000))
     702           0 :           (message nil)))
     703             :     ;; Clear out any old echo-area message to make way for our new thing.
     704           0 :     (message nil)
     705           0 :     (setq message (if (and (null args)
     706           0 :                            (string-match-p "\\` *\\[.+\\]\\'" message))
     707             :                       ;; Make sure we can put-text-property.
     708           0 :                       (copy-sequence message)
     709           0 :                     (concat " [" message "]")))
     710           0 :     (when args (setq message (apply #'format-message message args)))
     711           0 :     (let ((ol (make-overlay (point-max) (point-max) nil t t))
     712             :           ;; A quit during sit-for normally only interrupts the sit-for,
     713             :           ;; but since minibuffer-message is used at the end of a command,
     714             :           ;; at a time when the command has virtually finished already, a C-g
     715             :           ;; should really cause an abort-recursive-edit instead (i.e. as if
     716             :           ;; the C-g had been typed at top-level).  Binding inhibit-quit here
     717             :           ;; is an attempt to get that behavior.
     718             :           (inhibit-quit t))
     719           0 :       (unwind-protect
     720           0 :           (progn
     721           0 :             (unless (zerop (length message))
     722             :               ;; The current C cursor code doesn't know to use the overlay's
     723             :               ;; marker's stickiness to figure out whether to place the cursor
     724             :               ;; before or after the string, so let's spoon-feed it the pos.
     725           0 :               (put-text-property 0 1 'cursor t message))
     726           0 :             (overlay-put ol 'after-string message)
     727           0 :             (sit-for (or minibuffer-message-timeout 1000000)))
     728           0 :         (delete-overlay ol)))))
     729             : 
     730             : (defun minibuffer-completion-contents ()
     731             :   "Return the user input in a minibuffer before point as a string.
     732             : In Emacs-22, that was what completion commands operated on."
     733             :   (declare (obsolete nil "24.4"))
     734           0 :   (buffer-substring (minibuffer-prompt-end) (point)))
     735             : 
     736             : (defun delete-minibuffer-contents ()
     737             :   "Delete all user input in a minibuffer.
     738             : If the current buffer is not a minibuffer, erase its entire contents."
     739             :   (interactive)
     740             :   ;; We used to do `delete-field' here, but when file name shadowing
     741             :   ;; is on, the field doesn't cover the entire minibuffer contents.
     742           0 :   (delete-region (minibuffer-prompt-end) (point-max)))
     743             : 
     744             : (defvar completion-show-inline-help t
     745             :   "If non-nil, print helpful inline messages during completion.")
     746             : 
     747             : (defcustom completion-auto-help t
     748             :   "Non-nil means automatically provide help for invalid completion input.
     749             : If the value is t the *Completions* buffer is displayed whenever completion
     750             : is requested but cannot be done.
     751             : If the value is `lazy', the *Completions* buffer is only displayed after
     752             : the second failed attempt to complete."
     753             :   :type '(choice (const nil) (const t) (const lazy)))
     754             : 
     755             : (defconst completion-styles-alist
     756             :   '((emacs21
     757             :      completion-emacs21-try-completion completion-emacs21-all-completions
     758             :      "Simple prefix-based completion.
     759             : I.e. when completing \"foo_bar\" (where _ is the position of point),
     760             : it will consider all completions candidates matching the glob
     761             : pattern \"foobar*\".")
     762             :     (emacs22
     763             :      completion-emacs22-try-completion completion-emacs22-all-completions
     764             :      "Prefix completion that only operates on the text before point.
     765             : I.e. when completing \"foo_bar\" (where _ is the position of point),
     766             : it will consider all completions candidates matching the glob
     767             : pattern \"foo*\" and will add back \"bar\" to the end of it.")
     768             :     (basic
     769             :      completion-basic-try-completion completion-basic-all-completions
     770             :      "Completion of the prefix before point and the suffix after point.
     771             : I.e. when completing \"foo_bar\" (where _ is the position of point),
     772             : it will consider all completions candidates matching the glob
     773             : pattern \"foo*bar*\".")
     774             :     (partial-completion
     775             :      completion-pcm-try-completion completion-pcm-all-completions
     776             :      "Completion of multiple words, each one taken as a prefix.
     777             : I.e. when completing \"l-co_h\" (where _ is the position of point),
     778             : it will consider all completions candidates matching the glob
     779             : pattern \"l*-co*h*\".
     780             : Furthermore, for completions that are done step by step in subfields,
     781             : the method is applied to all the preceding fields that do not yet match.
     782             : E.g. C-x C-f /u/mo/s TAB could complete to /usr/monnier/src.
     783             : Additionally the user can use the char \"*\" as a glob pattern.")
     784             :     (substring
     785             :      completion-substring-try-completion completion-substring-all-completions
     786             :      "Completion of the string taken as a substring.
     787             : I.e. when completing \"foo_bar\" (where _ is the position of point),
     788             : it will consider all completions candidates matching the glob
     789             : pattern \"*foo*bar*\".")
     790             :     (initials
     791             :      completion-initials-try-completion completion-initials-all-completions
     792             :      "Completion of acronyms and initialisms.
     793             : E.g. can complete M-x lch to list-command-history
     794             : and C-x C-f ~/sew to ~/src/emacs/work."))
     795             :   "List of available completion styles.
     796             : Each element has the form (NAME TRY-COMPLETION ALL-COMPLETIONS DOC):
     797             : where NAME is the name that should be used in `completion-styles',
     798             : TRY-COMPLETION is the function that does the completion (it should
     799             : follow the same calling convention as `completion-try-completion'),
     800             : ALL-COMPLETIONS is the function that lists the completions (it should
     801             : follow the calling convention of `completion-all-completions'),
     802             : and DOC describes the way this style of completion works.")
     803             : 
     804             : (defconst completion--styles-type
     805             :   `(repeat :tag "insert a new menu to add more styles"
     806             :            (choice ,@(mapcar (lambda (x) (list 'const (car x)))
     807             :                              completion-styles-alist))))
     808             : (defconst completion--cycling-threshold-type
     809             :   '(choice (const :tag "No cycling" nil)
     810             :            (const :tag "Always cycle" t)
     811             :            (integer :tag "Threshold")))
     812             : 
     813             : (defcustom completion-styles
     814             :   ;; First, use `basic' because prefix completion has been the standard
     815             :   ;; for "ever" and works well in most cases, so using it first
     816             :   ;; ensures that we obey previous behavior in most cases.
     817             :   '(basic
     818             :     ;; Then use `partial-completion' because it has proven to
     819             :     ;; be a very convenient extension.
     820             :     partial-completion
     821             :     ;; Finally use `emacs22' so as to maintain (in many/most cases)
     822             :     ;; the previous behavior that when completing "foobar" with point
     823             :     ;; between "foo" and "bar" the completion try to complete "foo"
     824             :     ;; and simply add "bar" to the end of the result.
     825             :     emacs22)
     826             :   "List of completion styles to use.
     827             : The available styles are listed in `completion-styles-alist'.
     828             : 
     829             : Note that `completion-category-overrides' may override these
     830             : styles for specific categories, such as files, buffers, etc."
     831             :   :type completion--styles-type
     832             :   :version "23.1")
     833             : 
     834             : (defvar completion-category-defaults
     835             :   '((buffer (styles . (basic substring)))
     836             :     (unicode-name (styles . (basic substring)))
     837             :     (project-file (styles . (basic substring)))
     838             :     (info-menu (styles . (basic substring))))
     839             :   "Default settings for specific completion categories.
     840             : Each entry has the shape (CATEGORY . ALIST) where ALIST is
     841             : an association list that can specify properties such as:
     842             : - `styles': the list of `completion-styles' to use for that category.
     843             : - `cycle': the `completion-cycle-threshold' to use for that category.
     844             : Categories are symbols such as `buffer' and `file', used when
     845             : completing buffer and file names, respectively.")
     846             : 
     847             : (defcustom completion-category-overrides nil
     848             :   "List of category-specific user overrides for completion styles.
     849             : Each override has the shape (CATEGORY . ALIST) where ALIST is
     850             : an association list that can specify properties such as:
     851             : - `styles': the list of `completion-styles' to use for that category.
     852             : - `cycle': the `completion-cycle-threshold' to use for that category.
     853             : Categories are symbols such as `buffer' and `file', used when
     854             : completing buffer and file names, respectively.
     855             : This overrides the defaults specified in `completion-category-defaults'."
     856             :   :version "25.1"
     857             :   :type `(alist :key-type (choice :tag "Category"
     858             :                                   (const buffer)
     859             :                                   (const file)
     860             :                                   (const unicode-name)
     861             :                                   (const bookmark)
     862             :                                   symbol)
     863             :           :value-type
     864             :           (set :tag "Properties to override"
     865             :            (cons :tag "Completion Styles"
     866             :                  (const :tag "Select a style from the menu;" styles)
     867             :                  ,completion--styles-type)
     868             :            (cons :tag "Completion Cycling"
     869             :                  (const :tag "Select one value from the menu." cycle)
     870             :                  ,completion--cycling-threshold-type))))
     871             : 
     872             : (defun completion--category-override (category tag)
     873           0 :   (or (assq tag (cdr (assq category completion-category-overrides)))
     874           0 :       (assq tag (cdr (assq category completion-category-defaults)))))
     875             : 
     876             : (defun completion--styles (metadata)
     877           0 :   (let* ((cat (completion-metadata-get metadata 'category))
     878           0 :          (over (completion--category-override cat 'styles)))
     879           0 :     (if over
     880           0 :         (delete-dups (append (cdr over) (copy-sequence completion-styles)))
     881           0 :        completion-styles)))
     882             : 
     883             : (defun completion--nth-completion (n string table pred point metadata)
     884             :   "Call the Nth method of completion styles."
     885           0 :   (unless metadata
     886           0 :     (setq metadata
     887           0 :           (completion-metadata (substring string 0 point) table pred)))
     888             :   ;; We provide special support for quoting/unquoting here because it cannot
     889             :   ;; reliably be done within the normal completion-table routines: Completion
     890             :   ;; styles such as `substring' or `partial-completion' need to match the
     891             :   ;; output of all-completions with the user's input, and since most/all
     892             :   ;; quoting mechanisms allow several equivalent quoted forms, the
     893             :   ;; completion-style can't do this matching (e.g. `substring' doesn't know
     894             :   ;; that "\a\b\e" is a valid (quoted) substring of "label").
     895             :   ;; The quote/unquote function needs to come from the completion table (rather
     896             :   ;; than from completion-extra-properties) because it may apply only to some
     897             :   ;; part of the string (e.g. substitute-in-file-name).
     898           0 :   (let ((requote
     899           0 :          (when (completion-metadata-get metadata 'completion--unquote-requote)
     900           0 :            (cl-assert (functionp table))
     901           0 :            (let ((new (funcall table string point 'completion--unquote)))
     902           0 :              (setq string (pop new))
     903           0 :              (setq table (pop new))
     904           0 :              (setq point (pop new))
     905           0 :              (cl-assert (<= point (length string)))
     906           0 :              (pop new))))
     907             :         (result
     908           0 :          (completion--some (lambda (style)
     909           0 :                              (funcall (nth n (assq style
     910           0 :                                                    completion-styles-alist))
     911           0 :                                       string table pred point))
     912           0 :                            (completion--styles metadata))))
     913           0 :     (if requote
     914           0 :         (funcall requote result n)
     915           0 :       result)))
     916             : 
     917             : (defun completion-try-completion (string table pred point &optional metadata)
     918             :   "Try to complete STRING using completion table TABLE.
     919             : Only the elements of table that satisfy predicate PRED are considered.
     920             : POINT is the position of point within STRING.
     921             : The return value can be either nil to indicate that there is no completion,
     922             : t to indicate that STRING is the only possible completion,
     923             : or a pair (NEWSTRING . NEWPOINT) of the completed result string together with
     924             : a new position for point."
     925           0 :   (completion--nth-completion 1 string table pred point metadata))
     926             : 
     927             : (defun completion-all-completions (string table pred point &optional metadata)
     928             :   "List the possible completions of STRING in completion table TABLE.
     929             : Only the elements of table that satisfy predicate PRED are considered.
     930             : POINT is the position of point within STRING.
     931             : The return value is a list of completions and may contain the base-size
     932             : in the last `cdr'."
     933             :   ;; FIXME: We need to additionally return the info needed for the
     934             :   ;; second part of completion-base-position.
     935           0 :   (completion--nth-completion 2 string table pred point metadata))
     936             : 
     937             : (defun minibuffer--bitset (modified completions exact)
     938           0 :   (logior (if modified    4 0)
     939           0 :           (if completions 2 0)
     940           0 :           (if exact       1 0)))
     941             : 
     942             : (defun completion--replace (beg end newtext)
     943             :   "Replace the buffer text between BEG and END with NEWTEXT.
     944             : Moves point to the end of the new text."
     945             :   ;; The properties on `newtext' include things like
     946             :   ;; completions-first-difference, which we don't want to include
     947             :   ;; upon insertion.
     948           0 :   (set-text-properties 0 (length newtext) nil newtext)
     949             :   ;; Maybe this should be in subr.el.
     950             :   ;; You'd think this is trivial to do, but details matter if you want
     951             :   ;; to keep markers "at the right place" and be robust in the face of
     952             :   ;; after-change-functions that may themselves modify the buffer.
     953           0 :   (let ((prefix-len 0))
     954             :     ;; Don't touch markers in the shared prefix (if any).
     955           0 :     (while (and (< prefix-len (length newtext))
     956           0 :                 (< (+ beg prefix-len) end)
     957           0 :                 (eq (char-after (+ beg prefix-len))
     958           0 :                     (aref newtext prefix-len)))
     959           0 :       (setq prefix-len (1+ prefix-len)))
     960           0 :     (unless (zerop prefix-len)
     961           0 :       (setq beg (+ beg prefix-len))
     962           0 :       (setq newtext (substring newtext prefix-len))))
     963           0 :   (let ((suffix-len 0))
     964             :     ;; Don't touch markers in the shared suffix (if any).
     965           0 :     (while (and (< suffix-len (length newtext))
     966           0 :                 (< beg (- end suffix-len))
     967           0 :                 (eq (char-before (- end suffix-len))
     968           0 :                     (aref newtext (- (length newtext) suffix-len 1))))
     969           0 :       (setq suffix-len (1+ suffix-len)))
     970           0 :     (unless (zerop suffix-len)
     971           0 :       (setq end (- end suffix-len))
     972           0 :       (setq newtext (substring newtext 0 (- suffix-len))))
     973           0 :     (goto-char beg)
     974           0 :     (let ((length (- end beg)))         ;Read `end' before we insert the text.
     975           0 :       (insert-and-inherit newtext)
     976           0 :       (delete-region (point) (+ (point) length)))
     977           0 :     (forward-char suffix-len)))
     978             : 
     979             : (defcustom completion-cycle-threshold nil
     980             :   "Number of completion candidates below which cycling is used.
     981             : Depending on this setting `completion-in-region' may use cycling,
     982             : like `minibuffer-force-complete'.
     983             : If nil, cycling is never used.
     984             : If t, cycling is always used.
     985             : If an integer, cycling is used so long as there are not more
     986             : completion candidates than this number."
     987             :   :version "24.1"
     988             :   :type completion--cycling-threshold-type)
     989             : 
     990             : (defun completion--cycle-threshold (metadata)
     991           0 :   (let* ((cat (completion-metadata-get metadata 'category))
     992           0 :          (over (completion--category-override cat 'cycle)))
     993           0 :     (if over (cdr over) completion-cycle-threshold)))
     994             : 
     995             : (defvar-local completion-all-sorted-completions nil)
     996             : (defvar-local completion--all-sorted-completions-location nil)
     997             : (defvar completion-cycling nil)
     998             : 
     999             : (defvar completion-fail-discreetly nil
    1000             :   "If non-nil, stay quiet when there  is no match.")
    1001             : 
    1002             : (defun completion--message (msg)
    1003           0 :   (if completion-show-inline-help
    1004           0 :       (minibuffer-message msg)))
    1005             : 
    1006             : (defun completion--do-completion (beg end &optional
    1007             :                                       try-completion-function expect-exact)
    1008             :   "Do the completion and return a summary of what happened.
    1009             : M = completion was performed, the text was Modified.
    1010             : C = there were available Completions.
    1011             : E = after completion we now have an Exact match.
    1012             : 
    1013             :  MCE
    1014             :  000  0 no possible completion
    1015             :  001  1 was already an exact and unique completion
    1016             :  010  2 no completion happened
    1017             :  011  3 was already an exact completion
    1018             :  100  4 ??? impossible
    1019             :  101  5 ??? impossible
    1020             :  110  6 some completion happened
    1021             :  111  7 completed to an exact completion
    1022             : 
    1023             : TRY-COMPLETION-FUNCTION is a function to use in place of `try-completion'.
    1024             : EXPECT-EXACT, if non-nil, means that there is no need to tell the user
    1025             : when the buffer's text is already an exact match."
    1026           0 :   (let* ((string (buffer-substring beg end))
    1027           0 :          (md (completion--field-metadata beg))
    1028           0 :          (comp (funcall (or try-completion-function
    1029           0 :                             'completion-try-completion)
    1030           0 :                         string
    1031           0 :                         minibuffer-completion-table
    1032           0 :                         minibuffer-completion-predicate
    1033           0 :                         (- (point) beg)
    1034           0 :                         md)))
    1035           0 :     (cond
    1036           0 :      ((null comp)
    1037           0 :       (minibuffer-hide-completions)
    1038           0 :       (unless completion-fail-discreetly
    1039           0 :         (ding)
    1040           0 :         (completion--message "No match"))
    1041           0 :       (minibuffer--bitset nil nil nil))
    1042           0 :      ((eq t comp)
    1043           0 :       (minibuffer-hide-completions)
    1044           0 :       (goto-char end)
    1045           0 :       (completion--done string 'finished
    1046           0 :                         (unless expect-exact "Sole completion"))
    1047           0 :       (minibuffer--bitset nil nil t))   ;Exact and unique match.
    1048             :      (t
    1049             :       ;; `completed' should be t if some completion was done, which doesn't
    1050             :       ;; include simply changing the case of the entered string.  However,
    1051             :       ;; for appearance, the string is rewritten if the case changes.
    1052           0 :       (let* ((comp-pos (cdr comp))
    1053           0 :              (completion (car comp))
    1054           0 :              (completed (not (eq t (compare-strings completion nil nil
    1055           0 :                                                     string nil nil t))))
    1056           0 :              (unchanged (eq t (compare-strings completion nil nil
    1057           0 :                                                string nil nil nil))))
    1058           0 :         (if unchanged
    1059           0 :             (goto-char end)
    1060             :           ;; Insert in minibuffer the chars we got.
    1061           0 :           (completion--replace beg end completion)
    1062           0 :           (setq end (+ beg (length completion))))
    1063             :         ;; Move point to its completion-mandated destination.
    1064           0 :         (forward-char (- comp-pos (length completion)))
    1065             : 
    1066           0 :         (if (not (or unchanged completed))
    1067             :             ;; The case of the string changed, but that's all.  We're not sure
    1068             :             ;; whether this is a unique completion or not, so try again using
    1069             :             ;; the real case (this shouldn't recurse again, because the next
    1070             :             ;; time try-completion will return either t or the exact string).
    1071           0 :             (completion--do-completion beg end
    1072           0 :                                        try-completion-function expect-exact)
    1073             : 
    1074             :           ;; It did find a match.  Do we match some possibility exactly now?
    1075           0 :           (let* ((exact (test-completion completion
    1076           0 :                                          minibuffer-completion-table
    1077           0 :                                          minibuffer-completion-predicate))
    1078           0 :                  (threshold (completion--cycle-threshold md))
    1079             :                  (comps
    1080             :                   ;; Check to see if we want to do cycling.  We do it
    1081             :                   ;; here, after having performed the normal completion,
    1082             :                   ;; so as to take advantage of the difference between
    1083             :                   ;; try-completion and all-completions, for things
    1084             :                   ;; like completion-ignored-extensions.
    1085           0 :                   (when (and threshold
    1086             :                              ;; Check that the completion didn't make
    1087             :                              ;; us jump to a different boundary.
    1088           0 :                              (or (not completed)
    1089           0 :                                  (< (car (completion-boundaries
    1090           0 :                                           (substring completion 0 comp-pos)
    1091           0 :                                           minibuffer-completion-table
    1092           0 :                                           minibuffer-completion-predicate
    1093           0 :                                          ""))
    1094           0 :                                    comp-pos)))
    1095           0 :                    (completion-all-sorted-completions beg end))))
    1096           0 :             (completion--flush-all-sorted-completions)
    1097           0 :             (cond
    1098           0 :              ((and (consp (cdr comps)) ;; There's something to cycle.
    1099           0 :                    (not (ignore-errors
    1100             :                           ;; This signal an (intended) error if comps is too
    1101             :                           ;; short or if completion-cycle-threshold is t.
    1102           0 :                           (consp (nthcdr threshold comps)))))
    1103             :               ;; Not more than completion-cycle-threshold remaining
    1104             :               ;; completions: let's cycle.
    1105           0 :               (setq completed t exact t)
    1106           0 :               (completion--cache-all-sorted-completions beg end comps)
    1107           0 :               (minibuffer-force-complete beg end))
    1108           0 :              (completed
    1109             :               ;; We could also decide to refresh the completions,
    1110             :               ;; if they're displayed (and assuming there are
    1111             :               ;; completions left).
    1112           0 :               (minibuffer-hide-completions)
    1113           0 :               (if exact
    1114             :                   ;; If completion did not put point at end of field,
    1115             :                   ;; it's a sign that completion is not finished.
    1116           0 :                   (completion--done completion
    1117           0 :                                     (if (< comp-pos (length completion))
    1118           0 :                                         'exact 'unknown))))
    1119             :              ;; Show the completion table, if requested.
    1120           0 :              ((not exact)
    1121           0 :               (if (pcase completion-auto-help
    1122           0 :                     (`lazy (eq this-command last-command))
    1123           0 :                     (_ completion-auto-help))
    1124           0 :                   (minibuffer-completion-help beg end)
    1125           0 :                 (completion--message "Next char not unique")))
    1126             :              ;; If the last exact completion and this one were the same, it
    1127             :              ;; means we've already given a "Complete, but not unique" message
    1128             :              ;; and the user's hit TAB again, so now we give him help.
    1129             :              (t
    1130           0 :               (if (and (eq this-command last-command) completion-auto-help)
    1131           0 :                   (minibuffer-completion-help beg end))
    1132           0 :               (completion--done completion 'exact
    1133           0 :                                 (unless expect-exact
    1134           0 :                                   "Complete, but not unique"))))
    1135             : 
    1136           0 :             (minibuffer--bitset completed t exact))))))))
    1137             : 
    1138             : (defun minibuffer-complete ()
    1139             :   "Complete the minibuffer contents as far as possible.
    1140             : Return nil if there is no valid completion, else t.
    1141             : If no characters can be completed, display a list of possible completions.
    1142             : If you repeat this command after it displayed such a list,
    1143             : scroll the window of possible completions."
    1144             :   (interactive)
    1145           0 :   (when (<= (minibuffer-prompt-end) (point))
    1146           0 :     (completion-in-region (minibuffer-prompt-end) (point-max)
    1147           0 :                           minibuffer-completion-table
    1148           0 :                           minibuffer-completion-predicate)))
    1149             : 
    1150             : (defun completion--in-region-1 (beg end)
    1151             :   ;; If the previous command was not this,
    1152             :   ;; mark the completion buffer obsolete.
    1153           0 :   (setq this-command 'completion-at-point)
    1154           0 :   (unless (eq 'completion-at-point last-command)
    1155           0 :     (completion--flush-all-sorted-completions)
    1156           0 :     (setq minibuffer-scroll-window nil))
    1157             : 
    1158           0 :   (cond
    1159             :    ;; If there's a fresh completion window with a live buffer,
    1160             :    ;; and this command is repeated, scroll that window.
    1161           0 :    ((and (window-live-p minibuffer-scroll-window)
    1162           0 :          (eq t (frame-visible-p (window-frame minibuffer-scroll-window))))
    1163           0 :     (let ((window minibuffer-scroll-window))
    1164           0 :       (with-current-buffer (window-buffer window)
    1165           0 :         (if (pos-visible-in-window-p (point-max) window)
    1166             :             ;; If end is in view, scroll up to the beginning.
    1167           0 :             (set-window-start window (point-min) nil)
    1168             :           ;; Else scroll down one screen.
    1169           0 :           (with-selected-window window
    1170           0 :             (scroll-up)))
    1171           0 :         nil)))
    1172             :    ;; If we're cycling, keep on cycling.
    1173           0 :    ((and completion-cycling completion-all-sorted-completions)
    1174           0 :     (minibuffer-force-complete beg end)
    1175             :     t)
    1176           0 :    (t (pcase (completion--do-completion beg end)
    1177             :         (#b000 nil)
    1178           0 :         (_     t)))))
    1179             : 
    1180             : (defun completion--cache-all-sorted-completions (beg end comps)
    1181           0 :   (add-hook 'after-change-functions
    1182           0 :             'completion--flush-all-sorted-completions nil t)
    1183           0 :   (setq completion--all-sorted-completions-location
    1184           0 :         (cons (copy-marker beg) (copy-marker end)))
    1185           0 :   (setq completion-all-sorted-completions comps))
    1186             : 
    1187             : (defun completion--flush-all-sorted-completions (&optional start end _len)
    1188           0 :   (unless (and start end
    1189           0 :                (or (> start (cdr completion--all-sorted-completions-location))
    1190           0 :                    (< end (car completion--all-sorted-completions-location))))
    1191           0 :     (remove-hook 'after-change-functions
    1192           0 :                  'completion--flush-all-sorted-completions t)
    1193           0 :     (setq completion-cycling nil)
    1194           0 :     (setq completion-all-sorted-completions nil)))
    1195             : 
    1196             : (defun completion--metadata (string base md-at-point table pred)
    1197             :   ;; Like completion-metadata, but for the specific case of getting the
    1198             :   ;; metadata at `base', which tends to trigger pathological behavior for old
    1199             :   ;; completion tables which don't understand `metadata'.
    1200           0 :   (let ((bounds (completion-boundaries string table pred "")))
    1201           0 :     (if (eq (car bounds) base) md-at-point
    1202           0 :       (completion-metadata (substring string 0 base) table pred))))
    1203             : 
    1204             : (defun completion-all-sorted-completions (&optional start end)
    1205           0 :   (or completion-all-sorted-completions
    1206           0 :       (let* ((start (or start (minibuffer-prompt-end)))
    1207           0 :              (end (or end (point-max)))
    1208           0 :              (string (buffer-substring start end))
    1209           0 :              (md (completion--field-metadata start))
    1210           0 :              (all (completion-all-completions
    1211           0 :                    string
    1212           0 :                    minibuffer-completion-table
    1213           0 :                    minibuffer-completion-predicate
    1214           0 :                    (- (point) start)
    1215           0 :                    md))
    1216           0 :              (last (last all))
    1217           0 :              (base-size (or (cdr last) 0))
    1218           0 :              (all-md (completion--metadata (buffer-substring-no-properties
    1219           0 :                                             start (point))
    1220           0 :                                            base-size md
    1221           0 :                                            minibuffer-completion-table
    1222           0 :                                            minibuffer-completion-predicate))
    1223           0 :              (sort-fun (completion-metadata-get all-md 'cycle-sort-function)))
    1224           0 :         (when last
    1225           0 :           (setcdr last nil)
    1226             : 
    1227             :           ;; Delete duplicates: do it after setting last's cdr to nil (so
    1228             :           ;; it's a proper list), and be careful to reset `last' since it
    1229             :           ;; may be a different cons-cell.
    1230           0 :           (setq all (delete-dups all))
    1231           0 :           (setq last (last all))
    1232             : 
    1233           0 :           (setq all (if sort-fun (funcall sort-fun all)
    1234             :                       ;; Prefer shorter completions, by default.
    1235           0 :                       (sort all (lambda (c1 c2) (< (length c1) (length c2))))))
    1236             :           ;; Prefer recently used completions.
    1237           0 :           (when (minibufferp)
    1238           0 :             (let ((hist (symbol-value minibuffer-history-variable)))
    1239           0 :               (setq all (sort all (lambda (c1 c2)
    1240           0 :                                     (> (length (member c1 hist))
    1241           0 :                                        (length (member c2 hist))))))))
    1242             :           ;; Cache the result.  This is not just for speed, but also so that
    1243             :           ;; repeated calls to minibuffer-force-complete can cycle through
    1244             :           ;; all possibilities.
    1245           0 :           (completion--cache-all-sorted-completions
    1246           0 :            start end (nconc all base-size))))))
    1247             : 
    1248             : (defun minibuffer-force-complete-and-exit ()
    1249             :   "Complete the minibuffer with first of the matches and exit."
    1250             :   (interactive)
    1251           0 :   (minibuffer-force-complete)
    1252           0 :   (completion--complete-and-exit
    1253           0 :    (minibuffer-prompt-end) (point-max) #'exit-minibuffer
    1254             :    ;; If the previous completion completed to an element which fails
    1255             :    ;; test-completion, then we shouldn't exit, but that should be rare.
    1256           0 :    (lambda () (minibuffer-message "Incomplete"))))
    1257             : 
    1258             : (defun minibuffer-force-complete (&optional start end)
    1259             :   "Complete the minibuffer to an exact match.
    1260             : Repeated uses step through the possible completions."
    1261             :   (interactive)
    1262           0 :   (setq minibuffer-scroll-window nil)
    1263             :   ;; FIXME: Need to deal with the extra-size issue here as well.
    1264             :   ;; FIXME: ~/src/emacs/t<M-TAB>/lisp/minibuffer.el completes to
    1265             :   ;; ~/src/emacs/trunk/ and throws away lisp/minibuffer.el.
    1266           0 :   (let* ((start (copy-marker (or start (minibuffer-prompt-end))))
    1267           0 :          (end (or end (point-max)))
    1268             :          ;; (md (completion--field-metadata start))
    1269           0 :          (all (completion-all-sorted-completions start end))
    1270           0 :          (base (+ start (or (cdr (last all)) 0))))
    1271           0 :     (cond
    1272           0 :      ((not (consp all))
    1273           0 :         (completion--message
    1274           0 :        (if all "No more completions" "No completions")))
    1275           0 :      ((not (consp (cdr all)))
    1276           0 :       (let ((done (equal (car all) (buffer-substring-no-properties base end))))
    1277           0 :         (unless done (completion--replace base end (car all)))
    1278           0 :         (completion--done (buffer-substring-no-properties start (point))
    1279           0 :                           'finished (when done "Sole completion"))))
    1280             :      (t
    1281           0 :       (completion--replace base end (car all))
    1282           0 :       (setq end (+ base (length (car all))))
    1283           0 :       (completion--done (buffer-substring-no-properties start (point)) 'sole)
    1284             :       ;; Set cycling after modifying the buffer since the flush hook resets it.
    1285           0 :       (setq completion-cycling t)
    1286           0 :       (setq this-command 'completion-at-point) ;For completion-in-region.
    1287             :       ;; If completing file names, (car all) may be a directory, so we'd now
    1288             :       ;; have a new set of possible completions and might want to reset
    1289             :       ;; completion-all-sorted-completions to nil, but we prefer not to,
    1290             :       ;; so that repeated calls minibuffer-force-complete still cycle
    1291             :       ;; through the previous possible completions.
    1292           0 :       (let ((last (last all)))
    1293           0 :         (setcdr last (cons (car all) (cdr last)))
    1294           0 :         (completion--cache-all-sorted-completions start end (cdr all)))
    1295             :       ;; Make sure repeated uses cycle, even though completion--done might
    1296             :       ;; have added a space or something that moved us outside of the field.
    1297             :       ;; (bug#12221).
    1298           0 :       (let* ((table minibuffer-completion-table)
    1299           0 :              (pred minibuffer-completion-predicate)
    1300           0 :              (extra-prop completion-extra-properties)
    1301             :              (cmd
    1302             :               (lambda () "Cycle through the possible completions."
    1303             :                 (interactive)
    1304           0 :                 (let ((completion-extra-properties extra-prop))
    1305           0 :                   (completion-in-region start (point) table pred)))))
    1306           0 :         (set-transient-map
    1307           0 :          (let ((map (make-sparse-keymap)))
    1308           0 :            (define-key map [remap completion-at-point] cmd)
    1309           0 :            (define-key map (vector last-command-event) cmd)
    1310           0 :            map)))))))
    1311             : 
    1312             : (defvar minibuffer-confirm-exit-commands
    1313             :   '(completion-at-point minibuffer-complete
    1314             :     minibuffer-complete-word PC-complete PC-complete-word)
    1315             :   "A list of commands which cause an immediately following
    1316             : `minibuffer-complete-and-exit' to ask for extra confirmation.")
    1317             : 
    1318             : (defun minibuffer-complete-and-exit ()
    1319             :   "Exit if the minibuffer contains a valid completion.
    1320             : Otherwise, try to complete the minibuffer contents.  If
    1321             : completion leads to a valid completion, a repetition of this
    1322             : command will exit.
    1323             : 
    1324             : If `minibuffer-completion-confirm' is `confirm', do not try to
    1325             :  complete; instead, ask for confirmation and accept any input if
    1326             :  confirmed.
    1327             : If `minibuffer-completion-confirm' is `confirm-after-completion',
    1328             :  do not try to complete; instead, ask for confirmation if the
    1329             :  preceding minibuffer command was a member of
    1330             :  `minibuffer-confirm-exit-commands', and accept the input
    1331             :  otherwise."
    1332             :   (interactive)
    1333           0 :   (completion-complete-and-exit (minibuffer-prompt-end) (point-max)
    1334           0 :                                 #'exit-minibuffer))
    1335             : 
    1336             : (defun completion-complete-and-exit (beg end exit-function)
    1337           0 :   (completion--complete-and-exit
    1338           0 :    beg end exit-function
    1339             :    (lambda ()
    1340           0 :      (pcase (condition-case nil
    1341           0 :                 (completion--do-completion beg end
    1342           0 :                                            nil 'expect-exact)
    1343           0 :               (error 1))
    1344           0 :        ((or #b001 #b011) (funcall exit-function))
    1345           0 :        (#b111 (if (not minibuffer-completion-confirm)
    1346           0 :                   (funcall exit-function)
    1347           0 :                 (minibuffer-message "Confirm")
    1348           0 :                 nil))
    1349           0 :        (_ nil)))))
    1350             : 
    1351             : (defun completion--complete-and-exit (beg end
    1352             :                                           exit-function completion-function)
    1353             :   "Exit from `require-match' minibuffer.
    1354             : COMPLETION-FUNCTION is called if the current buffer's content does not
    1355             : appear to be a match."
    1356           0 :     (cond
    1357             :      ;; Allow user to specify null string
    1358           0 :    ((= beg end) (funcall exit-function))
    1359           0 :      ((test-completion (buffer-substring beg end)
    1360           0 :                        minibuffer-completion-table
    1361           0 :                        minibuffer-completion-predicate)
    1362             :       ;; FIXME: completion-ignore-case has various slightly
    1363             :       ;; incompatible meanings.  E.g. it can reflect whether the user
    1364             :       ;; wants completion to pay attention to case, or whether the
    1365             :       ;; string will be used in a context where case is significant.
    1366             :       ;; E.g. usually try-completion should obey the first, whereas
    1367             :       ;; test-completion should obey the second.
    1368           0 :       (when completion-ignore-case
    1369             :         ;; Fixup case of the field, if necessary.
    1370           0 :         (let* ((string (buffer-substring beg end))
    1371           0 :                (compl (try-completion
    1372           0 :                        string
    1373           0 :                        minibuffer-completion-table
    1374           0 :                        minibuffer-completion-predicate)))
    1375           0 :           (when (and (stringp compl) (not (equal string compl))
    1376             :                      ;; If it weren't for this piece of paranoia, I'd replace
    1377             :                      ;; the whole thing with a call to do-completion.
    1378             :                      ;; This is important, e.g. when the current minibuffer's
    1379             :                      ;; content is a directory which only contains a single
    1380             :                      ;; file, so `try-completion' actually completes to
    1381             :                      ;; that file.
    1382           0 :                      (= (length string) (length compl)))
    1383           0 :             (completion--replace beg end compl))))
    1384           0 :       (funcall exit-function))
    1385             : 
    1386           0 :      ((memq minibuffer-completion-confirm '(confirm confirm-after-completion))
    1387             :       ;; The user is permitted to exit with an input that's rejected
    1388             :       ;; by test-completion, after confirming her choice.
    1389           0 :       (if (or (eq last-command this-command)
    1390             :               ;; For `confirm-after-completion' we only ask for confirmation
    1391             :               ;; if trying to exit immediately after typing TAB (this
    1392             :               ;; catches most minibuffer typos).
    1393           0 :               (and (eq minibuffer-completion-confirm 'confirm-after-completion)
    1394           0 :                    (not (memq last-command minibuffer-confirm-exit-commands))))
    1395           0 :         (funcall exit-function)
    1396           0 :         (minibuffer-message "Confirm")
    1397           0 :         nil))
    1398             : 
    1399             :      (t
    1400             :       ;; Call do-completion, but ignore errors.
    1401           0 :       (funcall completion-function))))
    1402             : 
    1403             : (defun completion--try-word-completion (string table predicate point md)
    1404           0 :   (let ((comp (completion-try-completion string table predicate point md)))
    1405           0 :     (if (not (consp comp))
    1406           0 :         comp
    1407             : 
    1408             :       ;; If completion finds next char not unique,
    1409             :       ;; consider adding a space or a hyphen.
    1410           0 :       (when (= (length string) (length (car comp)))
    1411             :         ;; Mark the added char with the `completion-word' property, so it
    1412             :         ;; can be handled specially by completion styles such as
    1413             :         ;; partial-completion.
    1414             :         ;; We used to remove `partial-completion' from completion-styles
    1415             :         ;; instead, but it was too blunt, leading to situations where SPC
    1416             :         ;; was the only insertable char at point but minibuffer-complete-word
    1417             :         ;; refused inserting it.
    1418           0 :         (let ((exts (mapcar (lambda (str) (propertize str 'completion-try-word t))
    1419           0 :                             '(" " "-")))
    1420           0 :               (before (substring string 0 point))
    1421           0 :               (after (substring string point))
    1422             :               tem)
    1423             :           ;; If both " " and "-" lead to completions, prefer " " so SPC behaves
    1424             :           ;; a bit more like a self-inserting key (bug#17375).
    1425           0 :           (while (and exts (not (consp tem)))
    1426           0 :             (setq tem (completion-try-completion
    1427           0 :                        (concat before (pop exts) after)
    1428           0 :                        table predicate (1+ point) md)))
    1429           0 :           (if (consp tem) (setq comp tem))))
    1430             : 
    1431             :       ;; Completing a single word is actually more difficult than completing
    1432             :       ;; as much as possible, because we first have to find the "current
    1433             :       ;; position" in `completion' in order to find the end of the word
    1434             :       ;; we're completing.  Normally, `string' is a prefix of `completion',
    1435             :       ;; which makes it trivial to find the position, but with fancier
    1436             :       ;; completion (plus env-var expansion, ...) `completion' might not
    1437             :       ;; look anything like `string' at all.
    1438           0 :       (let* ((comppoint (cdr comp))
    1439           0 :              (completion (car comp))
    1440           0 :              (before (substring string 0 point))
    1441           0 :              (combined (concat before "\n" completion)))
    1442             :         ;; Find in completion the longest text that was right before point.
    1443           0 :         (when (string-match "\\(.+\\)\n.*?\\1" combined)
    1444           0 :           (let* ((prefix (match-string 1 before))
    1445             :                  ;; We used non-greedy match to make `rem' as long as possible.
    1446           0 :                  (rem (substring combined (match-end 0)))
    1447             :                  ;; Find in the remainder of completion the longest text
    1448             :                  ;; that was right after point.
    1449           0 :                  (after (substring string point))
    1450           0 :                  (suffix (if (string-match "\\`\\(.+\\).*\n.*\\1"
    1451           0 :                                            (concat after "\n" rem))
    1452           0 :                              (match-string 1 after))))
    1453             :             ;; The general idea is to try and guess what text was inserted
    1454             :             ;; at point by the completion.  Problem is: if we guess wrong,
    1455             :             ;; we may end up treating as "added by completion" text that was
    1456             :             ;; actually painfully typed by the user.  So if we then cut
    1457             :             ;; after the first word, we may throw away things the
    1458             :             ;; user wrote.  So let's try to be as conservative as possible:
    1459             :             ;; only cut after the first word, if we're reasonably sure that
    1460             :             ;; our guess is correct.
    1461             :             ;; Note: a quick survey on emacs-devel seemed to indicate that
    1462             :             ;; nobody actually cares about the "word-at-a-time" feature of
    1463             :             ;; minibuffer-complete-word, whose real raison-d'être is that it
    1464             :             ;; tries to add "-" or " ".  One more reason to only cut after
    1465             :             ;; the first word, if we're really sure we're right.
    1466           0 :             (when (and (or suffix (zerop (length after)))
    1467           0 :                        (string-match (concat
    1468             :                                       ;; Make submatch 1 as small as possible
    1469             :                                       ;; to reduce the risk of cutting
    1470             :                                       ;; valuable text.
    1471           0 :                                       ".*" (regexp-quote prefix) "\\(.*?\\)"
    1472           0 :                                       (if suffix (regexp-quote suffix) "\\'"))
    1473           0 :                                      completion)
    1474             :                        ;; The new point in `completion' should also be just
    1475             :                        ;; before the suffix, otherwise something more complex
    1476             :                        ;; is going on, and we're not sure where we are.
    1477           0 :                        (eq (match-end 1) comppoint)
    1478             :                        ;; (match-beginning 1)..comppoint is now the stretch
    1479             :                        ;; of text in `completion' that was completed at point.
    1480           0 :                        (string-match "\\W" completion (match-beginning 1))
    1481             :                        ;; Is there really something to cut?
    1482           0 :                        (> comppoint (match-end 0)))
    1483             :               ;; Cut after the first word.
    1484           0 :               (let ((cutpos (match-end 0)))
    1485           0 :                 (setq completion (concat (substring completion 0 cutpos)
    1486           0 :                                          (substring completion comppoint)))
    1487           0 :                 (setq comppoint cutpos)))))
    1488             : 
    1489           0 :         (cons completion comppoint)))))
    1490             : 
    1491             : 
    1492             : (defun minibuffer-complete-word ()
    1493             :   "Complete the minibuffer contents at most a single word.
    1494             : After one word is completed as much as possible, a space or hyphen
    1495             : is added, provided that matches some possible completion.
    1496             : Return nil if there is no valid completion, else t."
    1497             :   (interactive)
    1498           0 :   (completion-in-region--single-word
    1499           0 :    (minibuffer-prompt-end) (point-max)
    1500           0 :    minibuffer-completion-table minibuffer-completion-predicate))
    1501             : 
    1502             : (defun completion-in-region--single-word (beg end collection
    1503             :                                               &optional predicate)
    1504           0 :   (let ((minibuffer-completion-table collection)
    1505           0 :         (minibuffer-completion-predicate predicate))
    1506           0 :     (pcase (completion--do-completion beg end
    1507           0 :                                       #'completion--try-word-completion)
    1508             :     (#b000 nil)
    1509           0 :       (_     t))))
    1510             : 
    1511             : (defface completions-annotations '((t :inherit italic))
    1512             :   "Face to use for annotations in the *Completions* buffer.")
    1513             : 
    1514             : (defcustom completions-format 'horizontal
    1515             :   "Define the appearance and sorting of completions.
    1516             : If the value is `vertical', display completions sorted vertically
    1517             : in columns in the *Completions* buffer.
    1518             : If the value is `horizontal', display completions sorted
    1519             : horizontally in alphabetical order, rather than down the screen."
    1520             :   :type '(choice (const horizontal) (const vertical))
    1521             :   :version "23.2")
    1522             : 
    1523             : (defun completion--insert-strings (strings)
    1524             :   "Insert a list of STRINGS into the current buffer.
    1525             : Uses columns to keep the listing readable but compact.
    1526             : It also eliminates runs of equal strings."
    1527           0 :   (when (consp strings)
    1528           0 :     (let* ((length (apply 'max
    1529           0 :                           (mapcar (lambda (s)
    1530           0 :                                     (if (consp s)
    1531           0 :                                         (+ (string-width (car s))
    1532           0 :                                            (string-width (cadr s)))
    1533           0 :                                       (string-width s)))
    1534           0 :                                   strings)))
    1535           0 :            (window (get-buffer-window (current-buffer) 0))
    1536           0 :            (wwidth (if window (1- (window-width window)) 79))
    1537           0 :            (columns (min
    1538             :                      ;; At least 2 columns; at least 2 spaces between columns.
    1539           0 :                      (max 2 (/ wwidth (+ 2 length)))
    1540             :                      ;; Don't allocate more columns than we can fill.
    1541             :                      ;; Windows can't show less than 3 lines anyway.
    1542           0 :                      (max 1 (/ (length strings) 2))))
    1543           0 :            (colwidth (/ wwidth columns))
    1544             :            (column 0)
    1545           0 :            (rows (/ (length strings) columns))
    1546             :            (row 0)
    1547             :            (first t)
    1548             :            (laststring nil))
    1549             :       ;; The insertion should be "sensible" no matter what choices were made
    1550             :       ;; for the parameters above.
    1551           0 :       (dolist (str strings)
    1552           0 :         (unless (equal laststring str) ; Remove (consecutive) duplicates.
    1553           0 :           (setq laststring str)
    1554             :           ;; FIXME: `string-width' doesn't pay attention to
    1555             :           ;; `display' properties.
    1556           0 :           (let ((length (if (consp str)
    1557           0 :                             (+ (string-width (car str))
    1558           0 :                                (string-width (cadr str)))
    1559           0 :                           (string-width str))))
    1560           0 :             (cond
    1561           0 :              ((eq completions-format 'vertical)
    1562             :               ;; Vertical format
    1563           0 :               (when (> row rows)
    1564           0 :                 (forward-line (- -1 rows))
    1565           0 :                 (setq row 0 column (+ column colwidth)))
    1566           0 :               (when (> column 0)
    1567           0 :                 (end-of-line)
    1568           0 :                 (while (> (current-column) column)
    1569           0 :                   (if (eobp)
    1570           0 :                       (insert "\n")
    1571           0 :                     (forward-line 1)
    1572           0 :                     (end-of-line)))
    1573           0 :                 (insert " \t")
    1574           0 :                 (set-text-properties (1- (point)) (point)
    1575           0 :                                      `(display (space :align-to ,column)))))
    1576             :              (t
    1577             :               ;; Horizontal format
    1578           0 :               (unless first
    1579           0 :                 (if (< wwidth (+ (max colwidth length) column))
    1580             :                     ;; No space for `str' at point, move to next line.
    1581           0 :                     (progn (insert "\n") (setq column 0))
    1582           0 :                   (insert " \t")
    1583             :                   ;; Leave the space unpropertized so that in the case we're
    1584             :                   ;; already past the goal column, there is still
    1585             :                   ;; a space displayed.
    1586           0 :                   (set-text-properties (1- (point)) (point)
    1587             :                                        ;; We can't just set tab-width, because
    1588             :                                        ;; completion-setup-function will kill
    1589             :                                        ;; all local variables :-(
    1590           0 :                                        `(display (space :align-to ,column)))
    1591           0 :                   nil))))
    1592           0 :             (setq first nil)
    1593           0 :             (if (not (consp str))
    1594           0 :                 (put-text-property (point) (progn (insert str) (point))
    1595           0 :                                    'mouse-face 'highlight)
    1596           0 :               (put-text-property (point) (progn (insert (car str)) (point))
    1597           0 :                                  'mouse-face 'highlight)
    1598           0 :               (let ((beg (point))
    1599           0 :                     (end (progn (insert (cadr str)) (point))))
    1600           0 :                 (put-text-property beg end 'mouse-face nil)
    1601           0 :                 (font-lock-prepend-text-property beg end 'face
    1602           0 :                                                  'completions-annotations)))
    1603           0 :             (cond
    1604           0 :              ((eq completions-format 'vertical)
    1605             :               ;; Vertical format
    1606           0 :               (if (> column 0)
    1607           0 :                   (forward-line)
    1608           0 :                 (insert "\n"))
    1609           0 :               (setq row (1+ row)))
    1610             :              (t
    1611             :               ;; Horizontal format
    1612             :               ;; Next column to align to.
    1613           0 :               (setq column (+ column
    1614             :                               ;; Round up to a whole number of columns.
    1615           0 :                               (* colwidth (ceiling length colwidth))))))))))))
    1616             : 
    1617             : (defvar completion-common-substring nil)
    1618             : (make-obsolete-variable 'completion-common-substring nil "23.1")
    1619             : 
    1620             : (defvar completion-setup-hook nil
    1621             :   "Normal hook run at the end of setting up a completion list buffer.
    1622             : When this hook is run, the current buffer is the one in which the
    1623             : command to display the completion list buffer was run.
    1624             : The completion list buffer is available as the value of `standard-output'.
    1625             : See also `display-completion-list'.")
    1626             : 
    1627             : (defface completions-first-difference
    1628             :   '((t (:inherit bold)))
    1629             :   "Face for the first uncommon character in completions.
    1630             : See also the face `completions-common-part'.")
    1631             : 
    1632             : (defface completions-common-part '((t nil))
    1633             :   "Face for the common prefix substring in completions.
    1634             : The idea of this face is that you can use it to make the common parts
    1635             : less visible than normal, so that the differing parts are emphasized
    1636             : by contrast.
    1637             : See also the face `completions-first-difference'.")
    1638             : 
    1639             : (defun completion-hilit-commonality (completions prefix-len &optional base-size)
    1640             :   "Apply font-lock highlighting to a list of completions, COMPLETIONS.
    1641             : PREFIX-LEN is an integer.  BASE-SIZE is an integer or nil (meaning zero).
    1642             : 
    1643             : This adds the face `completions-common-part' to the first
    1644             : \(PREFIX-LEN - BASE-SIZE) characters of each completion, and the face
    1645             : `completions-first-difference' to the first character after that.
    1646             : 
    1647             : It returns a list with font-lock properties applied to each element,
    1648             : and with BASE-SIZE appended as the last element."
    1649           0 :   (when completions
    1650           0 :     (let ((com-str-len (- prefix-len (or base-size 0))))
    1651           0 :       (nconc
    1652           0 :        (mapcar
    1653             :         (lambda (elem)
    1654           0 :           (let ((str
    1655             :                  ;; Don't modify the string itself, but a copy, since the
    1656             :                  ;; the string may be read-only or used for other purposes.
    1657             :                  ;; Furthermore, since `completions' may come from
    1658             :                  ;; display-completion-list, `elem' may be a list.
    1659           0 :                  (if (consp elem)
    1660           0 :                      (car (setq elem (cons (copy-sequence (car elem))
    1661           0 :                                            (cdr elem))))
    1662           0 :                    (setq elem (copy-sequence elem)))))
    1663           0 :             (font-lock-prepend-text-property
    1664             :              0
    1665             :              ;; If completion-boundaries returns incorrect
    1666             :              ;; values, all-completions may return strings
    1667             :              ;; that don't contain the prefix.
    1668           0 :              (min com-str-len (length str))
    1669           0 :              'face 'completions-common-part str)
    1670           0 :             (if (> (length str) com-str-len)
    1671           0 :                 (font-lock-prepend-text-property com-str-len (1+ com-str-len)
    1672             :                                                  'face
    1673             :                                                  'completions-first-difference
    1674           0 :                                                  str)))
    1675           0 :           elem)
    1676           0 :         completions)
    1677           0 :        base-size))))
    1678             : 
    1679             : (defun display-completion-list (completions &optional common-substring)
    1680             :   "Display the list of completions, COMPLETIONS, using `standard-output'.
    1681             : Each element may be just a symbol or string
    1682             : or may be a list of two strings to be printed as if concatenated.
    1683             : If it is a list of two strings, the first is the actual completion
    1684             : alternative, the second serves as annotation.
    1685             : `standard-output' must be a buffer.
    1686             : The actual completion alternatives, as inserted, are given `mouse-face'
    1687             : properties of `highlight'.
    1688             : At the end, this runs the normal hook `completion-setup-hook'.
    1689             : It can find the completion buffer in `standard-output'."
    1690             :   (declare (advertised-calling-convention (completions) "24.4"))
    1691           0 :   (if common-substring
    1692           0 :       (setq completions (completion-hilit-commonality
    1693           0 :                          completions (length common-substring)
    1694             :                          ;; We don't know the base-size.
    1695           0 :                          nil)))
    1696           0 :   (if (not (bufferp standard-output))
    1697             :       ;; This *never* (ever) happens, so there's no point trying to be clever.
    1698           0 :       (with-temp-buffer
    1699           0 :         (let ((standard-output (current-buffer))
    1700             :               (completion-setup-hook nil))
    1701           0 :           (display-completion-list completions common-substring))
    1702           0 :         (princ (buffer-string)))
    1703             : 
    1704           0 :     (with-current-buffer standard-output
    1705           0 :       (goto-char (point-max))
    1706           0 :       (if (null completions)
    1707           0 :           (insert "There are no possible completions of what you have typed.")
    1708           0 :         (insert "Possible completions are:\n")
    1709           0 :         (completion--insert-strings completions))))
    1710             : 
    1711             :   ;; The hilit used to be applied via completion-setup-hook, so there
    1712             :   ;; may still be some code that uses completion-common-substring.
    1713           0 :   (with-no-warnings
    1714           0 :     (let ((completion-common-substring common-substring))
    1715           0 :       (run-hooks 'completion-setup-hook)))
    1716             :   nil)
    1717             : 
    1718             : (defvar completion-extra-properties nil
    1719             :   "Property list of extra properties of the current completion job.
    1720             : These include:
    1721             : 
    1722             : `:annotation-function': Function to annotate the completions buffer.
    1723             :    The function must accept one argument, a completion string,
    1724             :    and return either nil or a string which is to be displayed
    1725             :    next to the completion (but which is not part of the
    1726             :    completion).  The function can access the completion data via
    1727             :    `minibuffer-completion-table' and related variables.
    1728             : 
    1729             : `:exit-function': Function to run after completion is performed.
    1730             : 
    1731             :    The function must accept two arguments, STRING and STATUS.
    1732             :    STRING is the text to which the field was completed, and
    1733             :    STATUS indicates what kind of operation happened:
    1734             :      `finished' - text is now complete
    1735             :      `sole'     - text cannot be further completed but
    1736             :                   completion is not finished
    1737             :      `exact'    - text is a valid completion but may be further
    1738             :                   completed.")
    1739             : 
    1740             : (defvar completion-annotate-function
    1741             :   nil
    1742             :   ;; Note: there's a lot of scope as for when to add annotations and
    1743             :   ;; what annotations to add.  E.g. completing-help.el allowed adding
    1744             :   ;; the first line of docstrings to M-x completion.  But there's
    1745             :   ;; a tension, since such annotations, while useful at times, can
    1746             :   ;; actually drown the useful information.
    1747             :   ;; So completion-annotate-function should be used parsimoniously, or
    1748             :   ;; else only used upon a user's request (e.g. we could add a command
    1749             :   ;; to completion-list-mode to add annotations to the current
    1750             :   ;; completions).
    1751             :   "Function to add annotations in the *Completions* buffer.
    1752             : The function takes a completion and should either return nil, or a string that
    1753             : will be displayed next to the completion.  The function can access the
    1754             : completion table and predicates via `minibuffer-completion-table' and related
    1755             : variables.")
    1756             : (make-obsolete-variable 'completion-annotate-function
    1757             :                         'completion-extra-properties "24.1")
    1758             : 
    1759             : (defun completion--done (string &optional finished message)
    1760           0 :   (let* ((exit-fun (plist-get completion-extra-properties :exit-function))
    1761           0 :          (pre-msg (and exit-fun (current-message))))
    1762           0 :     (cl-assert (memq finished '(exact sole finished unknown)))
    1763           0 :     (when exit-fun
    1764           0 :       (when (eq finished 'unknown)
    1765           0 :         (setq finished
    1766           0 :               (if (eq (try-completion string
    1767           0 :                                       minibuffer-completion-table
    1768           0 :                                       minibuffer-completion-predicate)
    1769           0 :                       t)
    1770           0 :                   'finished 'exact)))
    1771           0 :       (funcall exit-fun string finished))
    1772           0 :     (when (and message
    1773             :                ;; Don't output any message if the exit-fun already did so.
    1774           0 :                (equal pre-msg (and exit-fun (current-message))))
    1775           0 :       (completion--message message))))
    1776             : 
    1777             : (defun minibuffer-completion-help (&optional start end)
    1778             :   "Display a list of possible completions of the current minibuffer contents."
    1779             :   (interactive)
    1780           0 :   (message "Making completion list...")
    1781           0 :   (let* ((start (or start (minibuffer-prompt-end)))
    1782           0 :          (end (or end (point-max)))
    1783           0 :          (string (buffer-substring start end))
    1784           0 :          (md (completion--field-metadata start))
    1785           0 :          (completions (completion-all-completions
    1786           0 :                        string
    1787           0 :                        minibuffer-completion-table
    1788           0 :                        minibuffer-completion-predicate
    1789           0 :                        (- (point) start)
    1790           0 :                        md)))
    1791           0 :     (message nil)
    1792           0 :     (if (or (null completions)
    1793           0 :             (and (not (consp (cdr completions)))
    1794           0 :                  (equal (car completions) string)))
    1795           0 :         (progn
    1796             :           ;; If there are no completions, or if the current input is already
    1797             :           ;; the sole completion, then hide (previous&stale) completions.
    1798           0 :           (minibuffer-hide-completions)
    1799           0 :           (ding)
    1800           0 :           (minibuffer-message
    1801           0 :            (if completions "Sole completion" "No completions")))
    1802             : 
    1803           0 :       (let* ((last (last completions))
    1804           0 :              (base-size (or (cdr last) 0))
    1805           0 :              (prefix (unless (zerop base-size) (substring string 0 base-size)))
    1806           0 :              (all-md (completion--metadata (buffer-substring-no-properties
    1807           0 :                                             start (point))
    1808           0 :                                            base-size md
    1809           0 :                                            minibuffer-completion-table
    1810           0 :                                            minibuffer-completion-predicate))
    1811           0 :              (afun (or (completion-metadata-get all-md 'annotation-function)
    1812           0 :                        (plist-get completion-extra-properties
    1813           0 :                                   :annotation-function)
    1814           0 :                        completion-annotate-function))
    1815             :              ;; If the *Completions* buffer is shown in a new
    1816             :              ;; window, mark it as softly-dedicated, so bury-buffer in
    1817             :              ;; minibuffer-hide-completions will know whether to
    1818             :              ;; delete the window or not.
    1819             :              (display-buffer-mark-dedicated 'soft)
    1820             :              ;; Disable `pop-up-windows' temporarily to allow
    1821             :              ;; `display-buffer--maybe-pop-up-frame-or-window'
    1822             :              ;; in the display actions below to pop up a frame
    1823             :              ;; if `pop-up-frames' is non-nil, but not to pop up a window.
    1824             :              (pop-up-windows nil))
    1825           0 :         (with-displayed-buffer-window
    1826             :           "*Completions*"
    1827             :           ;; This is a copy of `display-buffer-fallback-action'
    1828             :           ;; where `display-buffer-use-some-window' is replaced
    1829             :           ;; with `display-buffer-at-bottom'.
    1830           0 :           `((display-buffer--maybe-same-window
    1831             :              display-buffer-reuse-window
    1832             :              display-buffer--maybe-pop-up-frame-or-window
    1833             :              ;; Use `display-buffer-below-selected' for inline completions,
    1834             :              ;; but not in the minibuffer (e.g. in `eval-expression')
    1835             :              ;; for which `display-buffer-at-bottom' is used.
    1836           0 :              ,(if (eq (selected-window) (minibuffer-window))
    1837             :                   'display-buffer-at-bottom
    1838           0 :                 'display-buffer-below-selected))
    1839           0 :             ,(if temp-buffer-resize-mode
    1840             :                  '(window-height . resize-temp-buffer-window)
    1841           0 :                '(window-height . fit-window-to-buffer))
    1842           0 :             ,(when temp-buffer-resize-mode
    1843           0 :                '(preserve-size . (nil . t))))
    1844             :           nil
    1845             :           ;; Remove the base-size tail because `sort' requires a properly
    1846             :           ;; nil-terminated list.
    1847           0 :           (when last (setcdr last nil))
    1848           0 :           (setq completions
    1849             :                 ;; FIXME: This function is for the output of all-completions,
    1850             :                 ;; not completion-all-completions.  Often it's the same, but
    1851             :                 ;; not always.
    1852           0 :                 (let ((sort-fun (completion-metadata-get
    1853           0 :                                  all-md 'display-sort-function)))
    1854           0 :                   (if sort-fun
    1855           0 :                       (funcall sort-fun completions)
    1856           0 :                     (sort completions 'string-lessp))))
    1857           0 :           (when afun
    1858           0 :             (setq completions
    1859           0 :                   (mapcar (lambda (s)
    1860           0 :                             (let ((ann (funcall afun s)))
    1861           0 :                               (if ann (list s ann) s)))
    1862           0 :                           completions)))
    1863             : 
    1864           0 :           (with-current-buffer standard-output
    1865           0 :             (set (make-local-variable 'completion-base-position)
    1866           0 :                  (list (+ start base-size)
    1867             :                        ;; FIXME: We should pay attention to completion
    1868             :                        ;; boundaries here, but currently
    1869             :                        ;; completion-all-completions does not give us the
    1870             :                        ;; necessary information.
    1871           0 :                        end))
    1872           0 :             (set (make-local-variable 'completion-list-insert-choice-function)
    1873           0 :                  (let ((ctable minibuffer-completion-table)
    1874           0 :                        (cpred minibuffer-completion-predicate)
    1875           0 :                        (cprops completion-extra-properties))
    1876             :                    (lambda (start end choice)
    1877           0 :                      (unless (or (zerop (length prefix))
    1878           0 :                                  (equal prefix
    1879           0 :                                         (buffer-substring-no-properties
    1880           0 :                                          (max (point-min)
    1881           0 :                                               (- start (length prefix)))
    1882           0 :                                          start)))
    1883           0 :                        (message "*Completions* out of date"))
    1884             :                      ;; FIXME: Use `md' to do quoting&terminator here.
    1885           0 :                      (completion--replace start end choice)
    1886           0 :                      (let* ((minibuffer-completion-table ctable)
    1887           0 :                             (minibuffer-completion-predicate cpred)
    1888           0 :                             (completion-extra-properties cprops)
    1889           0 :                             (result (concat prefix choice))
    1890           0 :                             (bounds (completion-boundaries
    1891           0 :                                      result ctable cpred "")))
    1892             :                        ;; If the completion introduces a new field, then
    1893             :                        ;; completion is not finished.
    1894           0 :                        (completion--done result
    1895           0 :                                          (if (eq (car bounds) (length result))
    1896           0 :                                              'exact 'finished)))))))
    1897             : 
    1898           0 :           (display-completion-list completions))))
    1899           0 :     nil))
    1900             : 
    1901             : (defun minibuffer-hide-completions ()
    1902             :   "Get rid of an out-of-date *Completions* buffer."
    1903             :   ;; FIXME: We could/should use minibuffer-scroll-window here, but it
    1904             :   ;; can also point to the minibuffer-parent-window, so it's a bit tricky.
    1905           0 :   (let ((win (get-buffer-window "*Completions*" 0)))
    1906           0 :     (if win (with-selected-window win (bury-buffer)))))
    1907             : 
    1908             : (defun exit-minibuffer ()
    1909             :   "Terminate this minibuffer argument."
    1910             :   (interactive)
    1911             :   ;; If the command that uses this has made modifications in the minibuffer,
    1912             :   ;; we don't want them to cause deactivation of the mark in the original
    1913             :   ;; buffer.
    1914             :   ;; A better solution would be to make deactivate-mark buffer-local
    1915             :   ;; (or to turn it into a list of buffers, ...), but in the mean time,
    1916             :   ;; this should do the trick in most cases.
    1917           0 :   (setq deactivate-mark nil)
    1918           0 :   (throw 'exit nil))
    1919             : 
    1920             : (defun self-insert-and-exit ()
    1921             :   "Terminate minibuffer input."
    1922             :   (interactive)
    1923           0 :   (if (characterp last-command-event)
    1924           0 :       (call-interactively 'self-insert-command)
    1925           0 :     (ding))
    1926           0 :   (exit-minibuffer))
    1927             : 
    1928             : (defvar completion-in-region-functions nil
    1929             :   "Wrapper hook around `completion--in-region'.
    1930             : \(See `with-wrapper-hook' for details about wrapper hooks.)")
    1931             : (make-obsolete-variable 'completion-in-region-functions
    1932             :                         'completion-in-region-function "24.4")
    1933             : 
    1934             : (defvar completion-in-region-function #'completion--in-region
    1935             :   "Function to perform the job of `completion-in-region'.
    1936             : The function is called with 4 arguments: START END COLLECTION PREDICATE.
    1937             : The arguments and expected return value are as specified for
    1938             : `completion-in-region'.")
    1939             : 
    1940             : (defvar completion-in-region--data nil)
    1941             : 
    1942             : (defvar completion-in-region-mode-predicate nil
    1943             :   "Predicate to tell `completion-in-region-mode' when to exit.
    1944             : It is called with no argument and should return nil when
    1945             : `completion-in-region-mode' should exit (and hence pop down
    1946             : the *Completions* buffer).")
    1947             : 
    1948             : (defvar completion-in-region-mode--predicate nil
    1949             :   "Copy of the value of `completion-in-region-mode-predicate'.
    1950             : This holds the value `completion-in-region-mode-predicate' had when
    1951             : we entered `completion-in-region-mode'.")
    1952             : 
    1953             : (defun completion-in-region (start end collection &optional predicate)
    1954             :   "Complete the text between START and END using COLLECTION.
    1955             : Point needs to be somewhere between START and END.
    1956             : PREDICATE (a function called with no arguments) says when to exit.
    1957             : This calls the function that `completion-in-region-function' specifies
    1958             : \(passing the same four arguments that it received) to do the work,
    1959             : and returns whatever it does.  The return value should be nil
    1960             : if there was no valid completion, else t."
    1961           0 :   (cl-assert (<= start (point)) (<= (point) end))
    1962           0 :   (funcall completion-in-region-function start end collection predicate))
    1963             : 
    1964             : (defcustom read-file-name-completion-ignore-case
    1965             :   (if (memq system-type '(ms-dos windows-nt darwin cygwin))
    1966             :       t nil)
    1967             :   "Non-nil means when reading a file name completion ignores case."
    1968             :   :type 'boolean
    1969             :   :version "22.1")
    1970             : 
    1971             : (defun completion--in-region (start end collection &optional predicate)
    1972             :   "Default function to use for `completion-in-region-function'.
    1973             : Its arguments and return value are as specified for `completion-in-region'.
    1974             : Also respects the obsolete wrapper hook `completion-in-region-functions'.
    1975             : \(See `with-wrapper-hook' for details about wrapper hooks.)"
    1976           0 :   (subr--with-wrapper-hook-no-warnings
    1977             :       ;; FIXME: Maybe we should use this hook to provide a "display
    1978             :       ;; completions" operation as well.
    1979             :       completion-in-region-functions (start end collection predicate)
    1980             :     (let ((minibuffer-completion-table collection)
    1981             :           (minibuffer-completion-predicate predicate))
    1982             :       ;; HACK: if the text we are completing is already in a field, we
    1983             :       ;; want the completion field to take priority (e.g. Bug#6830).
    1984             :       (when completion-in-region-mode-predicate
    1985             :         (setq completion-in-region--data
    1986             :               `(,(if (markerp start) start (copy-marker start))
    1987             :                 ,(copy-marker end t) ,collection ,predicate))
    1988             :         (completion-in-region-mode 1))
    1989           0 :       (completion--in-region-1 start end))))
    1990             : 
    1991             : (defvar completion-in-region-mode-map
    1992             :   (let ((map (make-sparse-keymap)))
    1993             :     ;; FIXME: Only works if completion-in-region-mode was activated via
    1994             :     ;; completion-at-point called directly.
    1995             :     (define-key map "\M-?" 'completion-help-at-point)
    1996             :     (define-key map "\t" 'completion-at-point)
    1997             :     map)
    1998             :   "Keymap activated during `completion-in-region'.")
    1999             : 
    2000             : ;; It is difficult to know when to exit completion-in-region-mode (i.e. hide
    2001             : ;; the *Completions*).  Here's how previous packages did it:
    2002             : ;; - lisp-mode: never.
    2003             : ;; - comint: only do it if you hit SPC at the right time.
    2004             : ;; - pcomplete: pop it down on SPC or after some time-delay.
    2005             : ;; - semantic: use a post-command-hook check similar to this one.
    2006             : (defun completion-in-region--postch ()
    2007           0 :   (or unread-command-events ;Don't pop down the completions in the middle of
    2008             :                             ;mouse-drag-region/mouse-set-point.
    2009           0 :       (and completion-in-region--data
    2010           0 :            (and (eq (marker-buffer (nth 0 completion-in-region--data))
    2011           0 :                     (current-buffer))
    2012           0 :                 (>= (point) (nth 0 completion-in-region--data))
    2013           0 :                 (<= (point)
    2014           0 :                     (save-excursion
    2015           0 :                       (goto-char (nth 1 completion-in-region--data))
    2016           0 :                       (line-end-position)))
    2017           0 :                 (funcall completion-in-region-mode--predicate)))
    2018           0 :       (completion-in-region-mode -1)))
    2019             : 
    2020             : ;; (defalias 'completion-in-region--prech 'completion-in-region--postch)
    2021             : 
    2022             : (defvar completion-in-region-mode nil)  ;Explicit defvar, i.s.o defcustom.
    2023             : 
    2024             : (define-minor-mode completion-in-region-mode
    2025             :   "Transient minor mode used during `completion-in-region'."
    2026             :   :global t
    2027             :   :group 'minibuffer
    2028             :   ;; Prevent definition of a custom-variable since it makes no sense to
    2029             :   ;; customize this variable.
    2030             :   :variable completion-in-region-mode
    2031             :   ;; (remove-hook 'pre-command-hook #'completion-in-region--prech)
    2032           0 :   (remove-hook 'post-command-hook #'completion-in-region--postch)
    2033           0 :   (setq minor-mode-overriding-map-alist
    2034           0 :         (delq (assq 'completion-in-region-mode minor-mode-overriding-map-alist)
    2035           0 :               minor-mode-overriding-map-alist))
    2036           0 :   (if (null completion-in-region-mode)
    2037           0 :       (progn
    2038           0 :         (setq completion-in-region--data nil)
    2039           0 :         (unless (equal "*Completions*" (buffer-name (window-buffer)))
    2040           0 :           (minibuffer-hide-completions)))
    2041             :     ;; (add-hook 'pre-command-hook #'completion-in-region--prech)
    2042           0 :     (cl-assert completion-in-region-mode-predicate)
    2043           0 :     (setq completion-in-region-mode--predicate
    2044           0 :           completion-in-region-mode-predicate)
    2045           0 :     (add-hook 'post-command-hook #'completion-in-region--postch)
    2046           0 :     (push `(completion-in-region-mode . ,completion-in-region-mode-map)
    2047           0 :           minor-mode-overriding-map-alist)))
    2048             : 
    2049             : ;; Define-minor-mode added our keymap to minor-mode-map-alist, but we want it
    2050             : ;; on minor-mode-overriding-map-alist instead.
    2051             : (setq minor-mode-map-alist
    2052             :       (delq (assq 'completion-in-region-mode minor-mode-map-alist)
    2053             :             minor-mode-map-alist))
    2054             : 
    2055             : (defvar completion-at-point-functions '(tags-completion-at-point-function)
    2056             :   "Special hook to find the completion table for the entity at point.
    2057             : Each function on this hook is called in turn without any argument and
    2058             : should return either nil, meaning it is not applicable at point,
    2059             : or a function of no arguments to perform completion (discouraged),
    2060             : or a list of the form (START END COLLECTION . PROPS), where:
    2061             :  START and END delimit the entity to complete and should include point,
    2062             :  COLLECTION is the completion table to use to complete the entity, and
    2063             :  PROPS is a property list for additional information.
    2064             : Currently supported properties are all the properties that can appear in
    2065             : `completion-extra-properties' plus:
    2066             :  `:predicate'   a predicate that completion candidates need to satisfy.
    2067             :  `:exclusive'   value of `no' means that if the completion table fails to
    2068             :    match the text at point, then instead of reporting a completion
    2069             :    failure, the completion should try the next completion function.
    2070             : As is the case with most hooks, the functions are responsible for
    2071             : preserving things like point and current buffer.")
    2072             : 
    2073             : (defvar completion--capf-misbehave-funs nil
    2074             :   "List of functions found on `completion-at-point-functions' that misbehave.
    2075             : These are functions that neither return completion data nor a completion
    2076             : function but instead perform completion right away.")
    2077             : (defvar completion--capf-safe-funs nil
    2078             :   "List of well-behaved functions found on `completion-at-point-functions'.
    2079             : These are functions which return proper completion data rather than
    2080             : a completion function or god knows what else.")
    2081             : 
    2082             : (defun completion--capf-wrapper (fun which)
    2083             :   ;; FIXME: The safe/misbehave handling assumes that a given function will
    2084             :   ;; always return the same kind of data, but this breaks down with functions
    2085             :   ;; like comint-completion-at-point or mh-letter-completion-at-point, which
    2086             :   ;; could be sometimes safe and sometimes misbehaving (and sometimes neither).
    2087           0 :   (if (pcase which
    2088             :         (`all t)
    2089           0 :         (`safe (member fun completion--capf-safe-funs))
    2090           0 :         (`optimist (not (member fun completion--capf-misbehave-funs))))
    2091           0 :       (let ((res (funcall fun)))
    2092           0 :         (cond
    2093           0 :          ((and (consp res) (not (functionp res)))
    2094           0 :           (unless (member fun completion--capf-safe-funs)
    2095           0 :             (push fun completion--capf-safe-funs))
    2096           0 :           (and (eq 'no (plist-get (nthcdr 3 res) :exclusive))
    2097             :                ;; FIXME: Here we'd need to decide whether there are
    2098             :                ;; valid completions against the current text.  But this depends
    2099             :                ;; on the actual completion UI (e.g. with the default completion
    2100             :                ;; it depends on completion-style) ;-(
    2101             :                ;; We approximate this result by checking whether prefix
    2102             :                ;; completion might work, which means that non-prefix completion
    2103             :                ;; will not work (or not right) for completion functions that
    2104             :                ;; are non-exclusive.
    2105           0 :                (null (try-completion (buffer-substring-no-properties
    2106           0 :                                       (car res) (point))
    2107           0 :                                      (nth 2 res)
    2108           0 :                                      (plist-get (nthcdr 3 res) :predicate)))
    2109           0 :                (setq res nil)))
    2110           0 :          ((not (or (listp res) (functionp res)))
    2111           0 :           (unless (member fun completion--capf-misbehave-funs)
    2112           0 :             (message
    2113           0 :              "Completion function %S uses a deprecated calling convention" fun)
    2114           0 :             (push fun completion--capf-misbehave-funs))))
    2115           0 :         (if res (cons fun res)))))
    2116             : 
    2117             : (defun completion-at-point ()
    2118             :   "Perform completion on the text around point.
    2119             : The completion method is determined by `completion-at-point-functions'."
    2120             :   (interactive)
    2121           0 :   (let ((res (run-hook-wrapped 'completion-at-point-functions
    2122           0 :                                #'completion--capf-wrapper 'all)))
    2123           0 :     (pcase res
    2124           0 :       (`(,_ . ,(and (pred functionp) f)) (funcall f))
    2125             :       (`(,hookfun . (,start ,end ,collection . ,plist))
    2126           0 :        (unless (markerp start) (setq start (copy-marker start)))
    2127           0 :        (let* ((completion-extra-properties plist)
    2128             :               (completion-in-region-mode-predicate
    2129             :                (lambda ()
    2130             :                  ;; We're still in the same completion field.
    2131           0 :                  (let ((newstart (car-safe (funcall hookfun))))
    2132           0 :                    (and newstart (= newstart start))))))
    2133           0 :          (completion-in-region start end collection
    2134           0 :                                (plist-get plist :predicate))))
    2135             :       ;; Maybe completion already happened and the function returned t.
    2136             :       (_
    2137           0 :        (when (cdr res)
    2138           0 :          (message "Warning: %S failed to return valid completion data!"
    2139           0 :                   (car res)))
    2140           0 :        (cdr res)))))
    2141             : 
    2142             : (defun completion-help-at-point ()
    2143             :   "Display the completions on the text around point.
    2144             : The completion method is determined by `completion-at-point-functions'."
    2145             :   (interactive)
    2146           0 :   (let ((res (run-hook-wrapped 'completion-at-point-functions
    2147             :                                ;; Ignore misbehaving functions.
    2148           0 :                                #'completion--capf-wrapper 'optimist)))
    2149           0 :     (pcase res
    2150             :       (`(,_ . ,(and (pred functionp) f))
    2151           0 :        (message "Don't know how to show completions for %S" f))
    2152             :       (`(,hookfun . (,start ,end ,collection . ,plist))
    2153           0 :        (unless (markerp start) (setq start (copy-marker start)))
    2154           0 :        (let* ((minibuffer-completion-table collection)
    2155           0 :               (minibuffer-completion-predicate (plist-get plist :predicate))
    2156           0 :               (completion-extra-properties plist)
    2157             :               (completion-in-region-mode-predicate
    2158             :                (lambda ()
    2159             :                  ;; We're still in the same completion field.
    2160           0 :                  (let ((newstart (car-safe (funcall hookfun))))
    2161           0 :                    (and newstart (= newstart start))))))
    2162             :          ;; FIXME: We should somehow (ab)use completion-in-region-function or
    2163             :          ;; introduce a corresponding hook (plus another for word-completion,
    2164             :          ;; and another for force-completion, maybe?).
    2165           0 :          (setq completion-in-region--data
    2166           0 :                `(,start ,(copy-marker end t) ,collection
    2167           0 :                         ,(plist-get plist :predicate)))
    2168           0 :          (completion-in-region-mode 1)
    2169           0 :          (minibuffer-completion-help start end)))
    2170             :       (`(,hookfun . ,_)
    2171             :        ;; The hook function already performed completion :-(
    2172             :        ;; Not much we can do at this point.
    2173           0 :        (message "%s already performed completion!" hookfun)
    2174             :        nil)
    2175           0 :       (_ (message "Nothing to complete at point")))))
    2176             : 
    2177             : ;;; Key bindings.
    2178             : 
    2179             : (let ((map minibuffer-local-map))
    2180             :   (define-key map "\C-g" 'abort-recursive-edit)
    2181             :   (define-key map "\r" 'exit-minibuffer)
    2182             :   (define-key map "\n" 'exit-minibuffer))
    2183             : 
    2184             : (defvar minibuffer-local-completion-map
    2185             :   (let ((map (make-sparse-keymap)))
    2186             :     (set-keymap-parent map minibuffer-local-map)
    2187             :     (define-key map "\t" 'minibuffer-complete)
    2188             :     ;; M-TAB is already abused for many other purposes, so we should find
    2189             :     ;; another binding for it.
    2190             :     ;; (define-key map "\e\t" 'minibuffer-force-complete)
    2191             :     (define-key map " " 'minibuffer-complete-word)
    2192             :     (define-key map "?" 'minibuffer-completion-help)
    2193             :     map)
    2194             :   "Local keymap for minibuffer input with completion.")
    2195             : 
    2196             : (defvar minibuffer-local-must-match-map
    2197             :   (let ((map (make-sparse-keymap)))
    2198             :     (set-keymap-parent map minibuffer-local-completion-map)
    2199             :     (define-key map "\r" 'minibuffer-complete-and-exit)
    2200             :     (define-key map "\n" 'minibuffer-complete-and-exit)
    2201             :     map)
    2202             :   "Local keymap for minibuffer input with completion, for exact match.")
    2203             : 
    2204             : (defvar minibuffer-local-filename-completion-map
    2205             :   (let ((map (make-sparse-keymap)))
    2206             :     (define-key map " " nil)
    2207             :     map)
    2208             :   "Local keymap for minibuffer input with completion for filenames.
    2209             : Gets combined either with `minibuffer-local-completion-map' or
    2210             : with `minibuffer-local-must-match-map'.")
    2211             : 
    2212             : (define-obsolete-variable-alias 'minibuffer-local-must-match-filename-map
    2213             :   'minibuffer-local-filename-must-match-map "23.1")
    2214             : (defvar minibuffer-local-filename-must-match-map (make-sparse-keymap))
    2215             : (make-obsolete-variable 'minibuffer-local-filename-must-match-map nil "24.1")
    2216             : 
    2217             : (let ((map minibuffer-local-ns-map))
    2218             :   (define-key map " " 'exit-minibuffer)
    2219             :   (define-key map "\t" 'exit-minibuffer)
    2220             :   (define-key map "?" 'self-insert-and-exit))
    2221             : 
    2222             : (defvar minibuffer-inactive-mode-map
    2223             :   (let ((map (make-keymap)))
    2224             :     (suppress-keymap map)
    2225             :     (define-key map "e" 'find-file-other-frame)
    2226             :     (define-key map "f" 'find-file-other-frame)
    2227             :     (define-key map "b" 'switch-to-buffer-other-frame)
    2228             :     (define-key map "i" 'info)
    2229             :     (define-key map "m" 'mail)
    2230             :     (define-key map "n" 'make-frame)
    2231             :     (define-key map [mouse-1] 'view-echo-area-messages)
    2232             :     ;; So the global down-mouse-1 binding doesn't clutter the execution of the
    2233             :     ;; above mouse-1 binding.
    2234             :     (define-key map [down-mouse-1] #'ignore)
    2235             :     map)
    2236             :   "Keymap for use in the minibuffer when it is not active.
    2237             : The non-mouse bindings in this keymap can only be used in minibuffer-only
    2238             : frames, since the minibuffer can normally not be selected when it is
    2239             : not active.")
    2240             : 
    2241             : (define-derived-mode minibuffer-inactive-mode nil "InactiveMinibuffer"
    2242             :   :abbrev-table nil          ;abbrev.el is not loaded yet during dump.
    2243             :   ;; Note: this major mode is called from minibuf.c.
    2244             :   "Major mode to use in the minibuffer when it is not active.
    2245             : This is only used when the minibuffer area has no active minibuffer.")
    2246             : 
    2247             : ;;; Completion tables.
    2248             : 
    2249             : (defun minibuffer--double-dollars (str)
    2250             :   ;; Reuse the actual "$" from the string to preserve any text-property it
    2251             :   ;; might have, such as `face'.
    2252           0 :   (replace-regexp-in-string "\\$" (lambda (dollar) (concat dollar dollar))
    2253           0 :                             str))
    2254             : 
    2255             : (defun minibuffer-maybe-quote-filename (filename)
    2256             :   "Protect FILENAME from `substitute-in-file-name', as needed.
    2257             : Useful to give the user default values that won't be substituted."
    2258           0 :   (if (and (not (file-name-quoted-p filename))
    2259           0 :            (file-name-absolute-p filename)
    2260           0 :            (string-match-p (if (memq system-type '(windows-nt ms-dos))
    2261           0 :                                "[/\\\\]~" "/~")
    2262           0 :                            (file-local-name filename)))
    2263           0 :       (file-name-quote filename)
    2264           0 :     (minibuffer--double-dollars filename)))
    2265             : 
    2266             : (defun completion--make-envvar-table ()
    2267           0 :   (mapcar (lambda (enventry)
    2268           0 :             (substring enventry 0 (string-match-p "=" enventry)))
    2269           0 :           process-environment))
    2270             : 
    2271             : (defconst completion--embedded-envvar-re
    2272             :   ;; We can't reuse env--substitute-vars-regexp because we need to match only
    2273             :   ;; potentially-unfinished envvars at end of string.
    2274             :   (concat "\\(?:^\\|[^$]\\(?:\\$\\$\\)*\\)"
    2275             :           "$\\([[:alnum:]_]*\\|{\\([^}]*\\)\\)\\'"))
    2276             : 
    2277             : (defun completion--embedded-envvar-table (string _pred action)
    2278             :   "Completion table for envvars embedded in a string.
    2279             : The envvar syntax (and escaping) rules followed by this table are the
    2280             : same as `substitute-in-file-name'."
    2281             :   ;; We ignore `pred', because the predicates passed to us via
    2282             :   ;; read-file-name-internal are not 100% correct and fail here:
    2283             :   ;; e.g. we get predicates like file-directory-p there, whereas the filename
    2284             :   ;; completed needs to be passed through substitute-in-file-name before it
    2285             :   ;; can be passed to file-directory-p.
    2286           0 :   (when (string-match completion--embedded-envvar-re string)
    2287           0 :     (let* ((beg (or (match-beginning 2) (match-beginning 1)))
    2288           0 :            (table (completion--make-envvar-table))
    2289           0 :            (prefix (substring string 0 beg)))
    2290           0 :       (cond
    2291           0 :        ((eq action 'lambda)
    2292             :         ;; This table is expected to be used in conjunction with some
    2293             :         ;; other table that provides the "main" completion.  Let the
    2294             :         ;; other table handle the test-completion case.
    2295             :         nil)
    2296           0 :        ((or (eq (car-safe action) 'boundaries) (eq action 'metadata))
    2297             :         ;; Only return boundaries/metadata if there's something to complete,
    2298             :         ;; since otherwise when we're used in
    2299             :         ;; completion-table-in-turn, we could return boundaries and
    2300             :         ;; let some subsequent table return a list of completions.
    2301             :         ;; FIXME: Maybe it should rather be fixed in
    2302             :         ;; completion-table-in-turn instead, but it's difficult to
    2303             :         ;; do it efficiently there.
    2304           0 :         (when (try-completion (substring string beg) table nil)
    2305             :           ;; Compute the boundaries of the subfield to which this
    2306             :           ;; completion applies.
    2307           0 :           (if (eq action 'metadata)
    2308             :               '(metadata (category . environment-variable))
    2309           0 :             (let ((suffix (cdr action)))
    2310           0 :               `(boundaries
    2311           0 :                 ,(or (match-beginning 2) (match-beginning 1))
    2312           0 :                 . ,(when (string-match "[^[:alnum:]_]" suffix)
    2313           0 :                      (match-beginning 0)))))))
    2314             :        (t
    2315           0 :         (if (eq (aref string (1- beg)) ?{)
    2316           0 :             (setq table (apply-partially 'completion-table-with-terminator
    2317           0 :                                          "}" table)))
    2318             :         ;; Even if file-name completion is case-insensitive, we want
    2319             :         ;; envvar completion to be case-sensitive.
    2320           0 :         (let ((completion-ignore-case nil))
    2321           0 :           (completion-table-with-context
    2322           0 :            prefix table (substring string beg) nil action)))))))
    2323             : 
    2324             : (defun completion-file-name-table (string pred action)
    2325             :   "Completion table for file names."
    2326           0 :   (condition-case nil
    2327           0 :       (cond
    2328           0 :        ((eq action 'metadata) '(metadata (category . file)))
    2329           0 :        ((string-match-p "\\`~[^/\\]*\\'" string)
    2330           0 :         (completion-table-with-context "~"
    2331           0 :                                        (mapcar (lambda (u) (concat u "/"))
    2332           0 :                                                (system-users))
    2333           0 :                                        (substring string 1)
    2334           0 :                                        pred action))
    2335           0 :        ((eq (car-safe action) 'boundaries)
    2336           0 :         (let ((start (length (file-name-directory string)))
    2337           0 :               (end (string-match-p "/" (cdr action))))
    2338           0 :           `(boundaries
    2339             :             ;; if `string' is "C:" in w32, (file-name-directory string)
    2340             :             ;; returns "C:/", so `start' is 3 rather than 2.
    2341             :             ;; Not quite sure what is The Right Fix, but clipping it
    2342             :             ;; back to 2 will work for this particular case.  We'll
    2343             :             ;; see if we can come up with a better fix when we bump
    2344             :             ;; into more such problematic cases.
    2345           0 :             ,(min start (length string)) . ,end)))
    2346             : 
    2347           0 :        ((eq action 'lambda)
    2348           0 :         (if (zerop (length string))
    2349             :             nil          ;Not sure why it's here, but it probably doesn't harm.
    2350           0 :           (funcall (or pred 'file-exists-p) string)))
    2351             : 
    2352             :        (t
    2353           0 :         (let* ((name (file-name-nondirectory string))
    2354           0 :                (specdir (file-name-directory string))
    2355           0 :                (realdir (or specdir default-directory)))
    2356             : 
    2357           0 :           (cond
    2358           0 :            ((null action)
    2359           0 :             (let ((comp (file-name-completion name realdir pred)))
    2360           0 :               (if (stringp comp)
    2361           0 :                   (concat specdir comp)
    2362           0 :                 comp)))
    2363             : 
    2364           0 :            ((eq action t)
    2365           0 :             (let ((all (file-name-all-completions name realdir)))
    2366             : 
    2367             :               ;; Check the predicate, if necessary.
    2368           0 :               (unless (memq pred '(nil file-exists-p))
    2369           0 :                 (let ((comp ())
    2370             :                       (pred
    2371           0 :                        (if (eq pred 'file-directory-p)
    2372             :                            ;; Brute-force speed up for directory checking:
    2373             :                            ;; Discard strings which don't end in a slash.
    2374             :                            (lambda (s)
    2375           0 :                              (let ((len (length s)))
    2376           0 :                                (and (> len 0) (eq (aref s (1- len)) ?/))))
    2377             :                          ;; Must do it the hard (and slow) way.
    2378           0 :                          pred)))
    2379           0 :                   (let ((default-directory (expand-file-name realdir)))
    2380           0 :                     (dolist (tem all)
    2381           0 :                       (if (funcall pred tem) (push tem comp))))
    2382           0 :                   (setq all (nreverse comp))))
    2383             : 
    2384           0 :               all))))))
    2385           0 :     (file-error nil)))               ;PCM often calls with invalid directories.
    2386             : 
    2387             : (defvar read-file-name-predicate nil
    2388             :   "Current predicate used by `read-file-name-internal'.")
    2389             : (make-obsolete-variable 'read-file-name-predicate
    2390             :                         "use the regular PRED argument" "23.2")
    2391             : 
    2392             : (defun completion--sifn-requote (upos qstr)
    2393             :   ;; We're looking for `qpos' such that:
    2394             :   ;; (equal (substring (substitute-in-file-name qstr) 0 upos)
    2395             :   ;;        (substitute-in-file-name (substring qstr 0 qpos)))
    2396             :   ;; Big problem here: we have to reverse engineer substitute-in-file-name to
    2397             :   ;; find the position corresponding to UPOS in QSTR, but
    2398             :   ;; substitute-in-file-name can do anything, depending on file-name-handlers.
    2399             :   ;; substitute-in-file-name does the following kind of things:
    2400             :   ;; - expand env-var references.
    2401             :   ;; - turn backslashes into slashes.
    2402             :   ;; - truncate some prefix of the input.
    2403             :   ;; - rewrite some prefix.
    2404             :   ;; Some of these operations are written in external libraries and we'd rather
    2405             :   ;; not hard code any assumptions here about what they actually do.  IOW, we
    2406             :   ;; want to treat substitute-in-file-name as a black box, as much as possible.
    2407             :   ;; Kind of like in rfn-eshadow-update-overlay, only worse.
    2408             :   ;; Example of things we need to handle:
    2409             :   ;; - Tramp (substitute-in-file-name "/foo:~/bar//baz") => "/scpc:foo:/baz".
    2410             :   ;; - Cygwin (substitute-in-file-name "C:\bin") => "/usr/bin"
    2411             :   ;;          (substitute-in-file-name "C:\") => "/"
    2412             :   ;;          (substitute-in-file-name "C:\bi") => "/bi"
    2413           0 :   (let* ((ustr (substitute-in-file-name qstr))
    2414           0 :          (uprefix (substring ustr 0 upos))
    2415             :          qprefix)
    2416             :     ;; Main assumption: nothing after qpos should affect the text before upos,
    2417             :     ;; so we can work our way backward from the end of qstr, one character
    2418             :     ;; at a time.
    2419             :     ;; Second assumptions: If qpos is far from the end this can be a bit slow,
    2420             :     ;; so we speed it up by doing a first loop that skips a word at a time.
    2421             :     ;; This word-sized loop is careful not to cut in the middle of env-vars.
    2422           0 :     (while (let ((boundary (string-match "\\(\\$+{?\\)?\\w+\\W*\\'" qstr)))
    2423           0 :              (and boundary
    2424           0 :                   (progn
    2425           0 :                     (setq qprefix (substring qstr 0 boundary))
    2426           0 :                     (string-prefix-p uprefix
    2427           0 :                                    (substitute-in-file-name qprefix)))))
    2428           0 :       (setq qstr qprefix))
    2429           0 :     (let ((qpos (length qstr)))
    2430           0 :       (while (and (> qpos 0)
    2431           0 :                   (string-prefix-p uprefix
    2432           0 :                                    (substitute-in-file-name
    2433           0 :                                     (substring qstr 0 (1- qpos)))))
    2434           0 :         (setq qpos (1- qpos)))
    2435           0 :       (cons qpos #'minibuffer-maybe-quote-filename))))
    2436             : 
    2437             : (defalias 'completion--file-name-table
    2438             :   (completion-table-with-quoting #'completion-file-name-table
    2439             :                                  #'substitute-in-file-name
    2440             :                                  #'completion--sifn-requote)
    2441             :   "Internal subroutine for `read-file-name'.  Do not call this.
    2442             : This is a completion table for file names, like `completion-file-name-table'
    2443             : except that it passes the file name through `substitute-in-file-name'.")
    2444             : 
    2445             : (defalias 'read-file-name-internal
    2446             :   (completion-table-in-turn #'completion--embedded-envvar-table
    2447             :                             #'completion--file-name-table)
    2448             :   "Internal subroutine for `read-file-name'.  Do not call this.")
    2449             : 
    2450             : (defvar read-file-name-function 'read-file-name-default
    2451             :   "The function called by `read-file-name' to do its work.
    2452             : It should accept the same arguments as `read-file-name'.")
    2453             : 
    2454             : (defcustom insert-default-directory t
    2455             :   "Non-nil means when reading a filename start with default dir in minibuffer.
    2456             : 
    2457             : When the initial minibuffer contents show a name of a file or a directory,
    2458             : typing RETURN without editing the initial contents is equivalent to typing
    2459             : the default file name.
    2460             : 
    2461             : If this variable is non-nil, the minibuffer contents are always
    2462             : initially non-empty, and typing RETURN without editing will fetch the
    2463             : default name, if one is provided.  Note however that this default name
    2464             : is not necessarily the same as initial contents inserted in the minibuffer,
    2465             : if the initial contents is just the default directory.
    2466             : 
    2467             : If this variable is nil, the minibuffer often starts out empty.  In
    2468             : that case you may have to explicitly fetch the next history element to
    2469             : request the default name; typing RETURN without editing will leave
    2470             : the minibuffer empty.
    2471             : 
    2472             : For some commands, exiting with an empty minibuffer has a special meaning,
    2473             : such as making the current buffer visit no file in the case of
    2474             : `set-visited-file-name'."
    2475             :   :type 'boolean)
    2476             : 
    2477             : ;; Not always defined, but only called if next-read-file-uses-dialog-p says so.
    2478             : (declare-function x-file-dialog "xfns.c"
    2479             :                   (prompt dir &optional default-filename mustmatch only-dir-p))
    2480             : 
    2481             : (defun read-file-name--defaults (&optional dir initial)
    2482           0 :   (let ((default
    2483           0 :           (cond
    2484             :            ;; With non-nil `initial', use `dir' as the first default.
    2485             :            ;; Essentially, this mean reversing the normal order of the
    2486             :            ;; current directory name and the current file name, i.e.
    2487             :            ;; 1. with normal file reading:
    2488             :            ;; 1.1. initial input is the current directory
    2489             :            ;; 1.2. the first default is the current file name
    2490             :            ;; 2. with non-nil `initial' (e.g. for `find-alternate-file'):
    2491             :            ;; 2.2. initial input is the current file name
    2492             :            ;; 2.1. the first default is the current directory
    2493           0 :            (initial (abbreviate-file-name dir))
    2494             :            ;; In file buffers, try to get the current file name
    2495           0 :            (buffer-file-name
    2496           0 :             (abbreviate-file-name buffer-file-name))))
    2497             :         (file-name-at-point
    2498           0 :          (run-hook-with-args-until-success 'file-name-at-point-functions)))
    2499           0 :     (when file-name-at-point
    2500           0 :       (setq default (delete-dups
    2501           0 :                      (delete "" (delq nil (list file-name-at-point default))))))
    2502             :     ;; Append new defaults to the end of existing `minibuffer-default'.
    2503           0 :     (append
    2504           0 :      (if (listp minibuffer-default) minibuffer-default (list minibuffer-default))
    2505           0 :      (if (listp default) default (list default)))))
    2506             : 
    2507             : (defun read-file-name (prompt &optional dir default-filename mustmatch initial predicate)
    2508             :   "Read file name, prompting with PROMPT and completing in directory DIR.
    2509             : The return value is not expanded---you must call `expand-file-name' yourself.
    2510             : 
    2511             : DIR is the directory to use for completing relative file names.
    2512             : It should be an absolute directory name, or nil (which means the
    2513             : current buffer's value of `default-directory').
    2514             : 
    2515             : DEFAULT-FILENAME specifies the default file name to return if the
    2516             : user exits the minibuffer with the same non-empty string inserted
    2517             : by this function.  If DEFAULT-FILENAME is a string, that serves
    2518             : as the default.  If DEFAULT-FILENAME is a list of strings, the
    2519             : first string is the default.  If DEFAULT-FILENAME is omitted or
    2520             : nil, then if INITIAL is non-nil, the default is DIR combined with
    2521             : INITIAL; otherwise, if the current buffer is visiting a file,
    2522             : that file serves as the default; otherwise, the default is simply
    2523             : the string inserted into the minibuffer.
    2524             : 
    2525             : If the user exits with an empty minibuffer, return an empty
    2526             : string.  (This happens only if the user erases the pre-inserted
    2527             : contents, or if `insert-default-directory' is nil.)
    2528             : 
    2529             : Fourth arg MUSTMATCH can take the following values:
    2530             : - nil means that the user can exit with any input.
    2531             : - t means that the user is not allowed to exit unless
    2532             :   the input is (or completes to) an existing file.
    2533             : - `confirm' means that the user can exit with any input, but she needs
    2534             :   to confirm her choice if the input is not an existing file.
    2535             : - `confirm-after-completion' means that the user can exit with any
    2536             :   input, but she needs to confirm her choice if she called
    2537             :   `minibuffer-complete' right before `minibuffer-complete-and-exit'
    2538             :   and the input is not an existing file.
    2539             : - anything else behaves like t except that typing RET does not exit if it
    2540             :   does non-null completion.
    2541             : 
    2542             : Fifth arg INITIAL specifies text to start with.
    2543             : 
    2544             : Sixth arg PREDICATE, if non-nil, should be a function of one
    2545             : argument; then a file name is considered an acceptable completion
    2546             : alternative only if PREDICATE returns non-nil with the file name
    2547             : as its argument.
    2548             : 
    2549             : If this command was invoked with the mouse, use a graphical file
    2550             : dialog if `use-dialog-box' is non-nil, and the window system or X
    2551             : toolkit in use provides a file dialog box, and DIR is not a
    2552             : remote file.  For graphical file dialogs, any of the special values
    2553             : of MUSTMATCH `confirm' and `confirm-after-completion' are
    2554             : treated as equivalent to nil.  Some graphical file dialogs respect
    2555             : a MUSTMATCH value of t, and some do not (or it only has a cosmetic
    2556             : effect, and does not actually prevent the user from entering a
    2557             : non-existent file).
    2558             : 
    2559             : See also `read-file-name-completion-ignore-case'
    2560             : and `read-file-name-function'."
    2561             :   ;; If x-gtk-use-old-file-dialog = t (xg_get_file_with_selection),
    2562             :   ;; then MUSTMATCH is enforced.  But with newer Gtk
    2563             :   ;; (xg_get_file_with_chooser), it only has a cosmetic effect.
    2564             :   ;; The user can still type a non-existent file name.
    2565           0 :   (funcall (or read-file-name-function #'read-file-name-default)
    2566           0 :            prompt dir default-filename mustmatch initial predicate))
    2567             : 
    2568             : (defvar minibuffer-local-filename-syntax
    2569             :   (let ((table (make-syntax-table))
    2570             :         (punctuation (car (string-to-syntax "."))))
    2571             :     ;; Convert all punctuation entries to symbol.
    2572             :     (map-char-table (lambda (c syntax)
    2573             :                       (when (eq (car syntax) punctuation)
    2574             :                         (modify-syntax-entry c "_" table)))
    2575             :                     table)
    2576             :     (mapc
    2577             :      (lambda (c)
    2578             :        (modify-syntax-entry c "." table))
    2579             :      '(?/ ?: ?\\))
    2580             :     table)
    2581             :   "Syntax table used when reading a file name in the minibuffer.")
    2582             : 
    2583             : ;; minibuffer-completing-file-name is a variable used internally in minibuf.c
    2584             : ;; to determine whether to use minibuffer-local-filename-completion-map or
    2585             : ;; minibuffer-local-completion-map.  It shouldn't be exported to Elisp.
    2586             : ;; FIXME: Actually, it is also used in rfn-eshadow.el we'd otherwise have to
    2587             : ;; use (eq minibuffer-completion-table #'read-file-name-internal), which is
    2588             : ;; probably even worse.  Maybe We should add some read-file-name-setup-hook
    2589             : ;; instead, but for now, let's keep this non-obsolete.
    2590             : ;;(make-obsolete-variable 'minibuffer-completing-file-name nil "future" 'get)
    2591             : 
    2592             : (defun read-file-name-default (prompt &optional dir default-filename mustmatch initial predicate)
    2593             :   "Default method for reading file names.
    2594             : See `read-file-name' for the meaning of the arguments."
    2595           0 :   (unless dir (setq dir (or default-directory "~/")))
    2596           0 :   (unless (file-name-absolute-p dir) (setq dir (expand-file-name dir)))
    2597           0 :   (unless default-filename
    2598           0 :     (setq default-filename (if initial (expand-file-name initial dir)
    2599           0 :                              buffer-file-name)))
    2600             :   ;; If dir starts with user's homedir, change that to ~.
    2601           0 :   (setq dir (abbreviate-file-name dir))
    2602             :   ;; Likewise for default-filename.
    2603           0 :   (if default-filename
    2604           0 :       (setq default-filename
    2605           0 :             (if (consp default-filename)
    2606           0 :                 (mapcar 'abbreviate-file-name default-filename)
    2607           0 :               (abbreviate-file-name default-filename))))
    2608           0 :   (let ((insdef (cond
    2609           0 :                  ((and insert-default-directory (stringp dir))
    2610           0 :                   (if initial
    2611           0 :                       (cons (minibuffer-maybe-quote-filename (concat dir initial))
    2612           0 :                             (length (minibuffer-maybe-quote-filename dir)))
    2613           0 :                     (minibuffer-maybe-quote-filename dir)))
    2614           0 :                  (initial (cons (minibuffer-maybe-quote-filename initial) 0)))))
    2615             : 
    2616           0 :     (let ((completion-ignore-case read-file-name-completion-ignore-case)
    2617             :           (minibuffer-completing-file-name t)
    2618           0 :           (pred (or predicate 'file-exists-p))
    2619             :           (add-to-history nil))
    2620             : 
    2621           0 :       (let* ((val
    2622           0 :               (if (or (not (next-read-file-uses-dialog-p))
    2623             :                       ;; Graphical file dialogs can't handle remote
    2624             :                       ;; files (Bug#99).
    2625           0 :                       (file-remote-p dir))
    2626             :                   ;; We used to pass `dir' to `read-file-name-internal' by
    2627             :                   ;; abusing the `predicate' argument.  It's better to
    2628             :                   ;; just use `default-directory', but in order to avoid
    2629             :                   ;; changing `default-directory' in the current buffer,
    2630             :                   ;; we don't let-bind it.
    2631           0 :                   (let ((dir (file-name-as-directory
    2632           0 :                               (expand-file-name dir))))
    2633           0 :                     (minibuffer-with-setup-hook
    2634             :                         (lambda ()
    2635           0 :                           (setq default-directory dir)
    2636             :                           ;; When the first default in `minibuffer-default'
    2637             :                           ;; duplicates initial input `insdef',
    2638             :                           ;; reset `minibuffer-default' to nil.
    2639           0 :                           (when (equal (or (car-safe insdef) insdef)
    2640           0 :                                        (or (car-safe minibuffer-default)
    2641           0 :                                            minibuffer-default))
    2642           0 :                             (setq minibuffer-default
    2643           0 :                                   (cdr-safe minibuffer-default)))
    2644             :                           ;; On the first request on `M-n' fill
    2645             :                           ;; `minibuffer-default' with a list of defaults
    2646             :                           ;; relevant for file-name reading.
    2647           0 :                           (set (make-local-variable 'minibuffer-default-add-function)
    2648             :                                (lambda ()
    2649           0 :                                  (with-current-buffer
    2650           0 :                                      (window-buffer (minibuffer-selected-window))
    2651           0 :                                    (read-file-name--defaults dir initial))))
    2652           0 :                           (set-syntax-table minibuffer-local-filename-syntax))
    2653           0 :                       (completing-read prompt 'read-file-name-internal
    2654           0 :                                        pred mustmatch insdef
    2655           0 :                                        'file-name-history default-filename)))
    2656             :                 ;; If DEFAULT-FILENAME not supplied and DIR contains
    2657             :                 ;; a file name, split it.
    2658           0 :                 (let ((file (file-name-nondirectory dir))
    2659             :                       ;; When using a dialog, revert to nil and non-nil
    2660             :                       ;; interpretation of mustmatch. confirm options
    2661             :                       ;; need to be interpreted as nil, otherwise
    2662             :                       ;; it is impossible to create new files using
    2663             :                       ;; dialogs with the default settings.
    2664             :                       (dialog-mustmatch
    2665           0 :                        (not (memq mustmatch
    2666           0 :                                   '(nil confirm confirm-after-completion)))))
    2667           0 :                   (when (and (not default-filename)
    2668           0 :                              (not (zerop (length file))))
    2669           0 :                     (setq default-filename file)
    2670           0 :                     (setq dir (file-name-directory dir)))
    2671           0 :                   (when default-filename
    2672           0 :                     (setq default-filename
    2673           0 :                           (expand-file-name (if (consp default-filename)
    2674           0 :                                                 (car default-filename)
    2675           0 :                                               default-filename)
    2676           0 :                                             dir)))
    2677           0 :                   (setq add-to-history t)
    2678           0 :                   (x-file-dialog prompt dir default-filename
    2679           0 :                                  dialog-mustmatch
    2680           0 :                                  (eq predicate 'file-directory-p)))))
    2681             : 
    2682           0 :              (replace-in-history (eq (car-safe file-name-history) val)))
    2683             :         ;; If completing-read returned the inserted default string itself
    2684             :         ;; (rather than a new string with the same contents),
    2685             :         ;; it has to mean that the user typed RET with the minibuffer empty.
    2686             :         ;; In that case, we really want to return ""
    2687             :         ;; so that commands such as set-visited-file-name can distinguish.
    2688           0 :         (when (consp default-filename)
    2689           0 :           (setq default-filename (car default-filename)))
    2690           0 :         (when (eq val default-filename)
    2691             :           ;; In this case, completing-read has not added an element
    2692             :           ;; to the history.  Maybe we should.
    2693           0 :           (if (not replace-in-history)
    2694           0 :               (setq add-to-history t))
    2695           0 :           (setq val ""))
    2696           0 :         (unless val (error "No file name specified"))
    2697             : 
    2698           0 :         (if (and default-filename
    2699           0 :                  (string-equal val (if (consp insdef) (car insdef) insdef)))
    2700           0 :             (setq val default-filename))
    2701           0 :         (setq val (substitute-in-file-name val))
    2702             : 
    2703           0 :         (if replace-in-history
    2704             :             ;; Replace what Fcompleting_read added to the history
    2705             :             ;; with what we will actually return.  As an exception,
    2706             :             ;; if that's the same as the second item in
    2707             :             ;; file-name-history, it's really a repeat (Bug#4657).
    2708           0 :             (let ((val1 (minibuffer-maybe-quote-filename val)))
    2709           0 :               (if history-delete-duplicates
    2710           0 :                   (setcdr file-name-history
    2711           0 :                           (delete val1 (cdr file-name-history))))
    2712           0 :               (if (string= val1 (cadr file-name-history))
    2713           0 :                   (pop file-name-history)
    2714           0 :                 (setcar file-name-history val1)))
    2715           0 :           (if add-to-history
    2716             :               ;; Add the value to the history--but not if it matches
    2717             :               ;; the last value already there.
    2718           0 :               (let ((val1 (minibuffer-maybe-quote-filename val)))
    2719           0 :                 (unless (and (consp file-name-history)
    2720           0 :                              (equal (car file-name-history) val1))
    2721           0 :                   (setq file-name-history
    2722           0 :                         (cons val1
    2723           0 :                               (if history-delete-duplicates
    2724           0 :                                   (delete val1 file-name-history)
    2725           0 :                                 file-name-history)))))))
    2726           0 :         val))))
    2727             : 
    2728             : (defun internal-complete-buffer-except (&optional buffer)
    2729             :   "Perform completion on all buffers excluding BUFFER.
    2730             : BUFFER nil or omitted means use the current buffer.
    2731             : Like `internal-complete-buffer', but removes BUFFER from the completion list."
    2732           0 :   (let ((except (if (stringp buffer) buffer (buffer-name buffer))))
    2733           0 :     (apply-partially 'completion-table-with-predicate
    2734             :                      'internal-complete-buffer
    2735             :                      (lambda (name)
    2736           0 :                        (not (equal (if (consp name) (car name) name) except)))
    2737           0 :                      nil)))
    2738             : 
    2739             : ;;; Old-style completion, used in Emacs-21 and Emacs-22.
    2740             : 
    2741             : (defun completion-emacs21-try-completion (string table pred _point)
    2742           0 :   (let ((completion (try-completion string table pred)))
    2743           0 :     (if (stringp completion)
    2744           0 :         (cons completion (length completion))
    2745           0 :       completion)))
    2746             : 
    2747             : (defun completion-emacs21-all-completions (string table pred _point)
    2748           0 :   (completion-hilit-commonality
    2749           0 :    (all-completions string table pred)
    2750           0 :    (length string)
    2751           0 :    (car (completion-boundaries string table pred ""))))
    2752             : 
    2753             : (defun completion-emacs22-try-completion (string table pred point)
    2754           0 :   (let ((suffix (substring string point))
    2755           0 :         (completion (try-completion (substring string 0 point) table pred)))
    2756           0 :     (if (not (stringp completion))
    2757           0 :         completion
    2758             :       ;; Merge a trailing / in completion with a / after point.
    2759             :       ;; We used to only do it for word completion, but it seems to make
    2760             :       ;; sense for all completions.
    2761             :       ;; Actually, claiming this feature was part of Emacs-22 completion
    2762             :       ;; is pushing it a bit: it was only done in minibuffer-completion-word,
    2763             :       ;; which was (by default) not bound during file completion, where such
    2764             :       ;; slashes are most likely to occur.
    2765           0 :       (if (and (not (zerop (length completion)))
    2766           0 :                (eq ?/ (aref completion (1- (length completion))))
    2767           0 :                (not (zerop (length suffix)))
    2768           0 :                (eq ?/ (aref suffix 0)))
    2769             :           ;; This leaves point after the / .
    2770           0 :           (setq suffix (substring suffix 1)))
    2771           0 :       (cons (concat completion suffix) (length completion)))))
    2772             : 
    2773             : (defun completion-emacs22-all-completions (string table pred point)
    2774           0 :   (let ((beforepoint (substring string 0 point)))
    2775           0 :     (completion-hilit-commonality
    2776           0 :      (all-completions beforepoint table pred)
    2777           0 :      point
    2778           0 :      (car (completion-boundaries beforepoint table pred "")))))
    2779             : 
    2780             : ;;; Basic completion.
    2781             : 
    2782             : (defun completion--merge-suffix (completion point suffix)
    2783             :   "Merge end of COMPLETION with beginning of SUFFIX.
    2784             : Simple generalization of the \"merge trailing /\" done in Emacs-22.
    2785             : Return the new suffix."
    2786           0 :   (if (and (not (zerop (length suffix)))
    2787           0 :            (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix)
    2788             :                          ;; Make sure we don't compress things to less
    2789             :                          ;; than we started with.
    2790           0 :                          point)
    2791             :            ;; Just make sure we didn't match some other \n.
    2792           0 :            (eq (match-end 1) (length completion)))
    2793           0 :       (substring suffix (- (match-end 1) (match-beginning 1)))
    2794             :     ;; Nothing to merge.
    2795           0 :     suffix))
    2796             : 
    2797             : (defun completion-basic--pattern (beforepoint afterpoint bounds)
    2798           0 :   (delete
    2799           0 :    "" (list (substring beforepoint (car bounds))
    2800             :             'point
    2801           0 :             (substring afterpoint 0 (cdr bounds)))))
    2802             : 
    2803             : (defun completion-basic-try-completion (string table pred point)
    2804           0 :   (let* ((beforepoint (substring string 0 point))
    2805           0 :          (afterpoint (substring string point))
    2806           0 :          (bounds (completion-boundaries beforepoint table pred afterpoint)))
    2807           0 :     (if (zerop (cdr bounds))
    2808             :         ;; `try-completion' may return a subtly different result
    2809             :         ;; than `all+merge', so try to use it whenever possible.
    2810           0 :         (let ((completion (try-completion beforepoint table pred)))
    2811           0 :           (if (not (stringp completion))
    2812           0 :               completion
    2813           0 :             (cons
    2814           0 :              (concat completion
    2815           0 :                      (completion--merge-suffix completion point afterpoint))
    2816           0 :              (length completion))))
    2817           0 :       (let* ((suffix (substring afterpoint (cdr bounds)))
    2818           0 :              (prefix (substring beforepoint 0 (car bounds)))
    2819           0 :              (pattern (delete
    2820           0 :                        "" (list (substring beforepoint (car bounds))
    2821             :                                 'point
    2822           0 :                                 (substring afterpoint 0 (cdr bounds)))))
    2823           0 :              (all (completion-pcm--all-completions prefix pattern table pred)))
    2824           0 :         (if minibuffer-completing-file-name
    2825           0 :             (setq all (completion-pcm--filename-try-filter all)))
    2826           0 :         (completion-pcm--merge-try pattern all prefix suffix)))))
    2827             : 
    2828             : (defun completion-basic-all-completions (string table pred point)
    2829           0 :   (let* ((beforepoint (substring string 0 point))
    2830           0 :          (afterpoint (substring string point))
    2831           0 :          (bounds (completion-boundaries beforepoint table pred afterpoint))
    2832             :          ;; (suffix (substring afterpoint (cdr bounds)))
    2833           0 :          (prefix (substring beforepoint 0 (car bounds)))
    2834           0 :          (pattern (delete
    2835           0 :                    "" (list (substring beforepoint (car bounds))
    2836             :                             'point
    2837           0 :                             (substring afterpoint 0 (cdr bounds)))))
    2838           0 :          (all (completion-pcm--all-completions prefix pattern table pred)))
    2839           0 :     (completion-hilit-commonality all point (car bounds))))
    2840             : 
    2841             : ;;; Partial-completion-mode style completion.
    2842             : 
    2843             : (defvar completion-pcm--delim-wild-regex nil
    2844             :   "Regular expression matching delimiters controlling the partial-completion.
    2845             : Typically, this regular expression simply matches a delimiter, meaning
    2846             : that completion can add something at (match-beginning 0), but if it has
    2847             : a submatch 1, then completion can add something at (match-end 1).
    2848             : This is used when the delimiter needs to be of size zero (e.g. the transition
    2849             : from lowercase to uppercase characters).")
    2850             : 
    2851             : (defun completion-pcm--prepare-delim-re (delims)
    2852           1 :   (setq completion-pcm--delim-wild-regex (concat "[" delims "*]")))
    2853             : 
    2854             : (defcustom completion-pcm-word-delimiters "-_./:| "
    2855             :   "A string of characters treated as word delimiters for completion.
    2856             : Some arcane rules:
    2857             : If `]' is in this string, it must come first.
    2858             : If `^' is in this string, it must not come first.
    2859             : If `-' is in this string, it must come first or right after `]'.
    2860             : In other words, if S is this string, then `[S]' must be a valid Emacs regular
    2861             : expression (not containing character ranges like `a-z')."
    2862             :   :set (lambda (symbol value)
    2863             :          (set-default symbol value)
    2864             :          ;; Refresh other vars.
    2865             :          (completion-pcm--prepare-delim-re value))
    2866             :   :initialize 'custom-initialize-reset
    2867             :   :type 'string)
    2868             : 
    2869             : (defcustom completion-pcm-complete-word-inserts-delimiters nil
    2870             :   "Treat the SPC or - inserted by `minibuffer-complete-word' as delimiters.
    2871             : Those chars are treated as delimiters if this variable is non-nil.
    2872             : I.e. if non-nil, M-x SPC will just insert a \"-\" in the minibuffer, whereas
    2873             : if nil, it will list all possible commands in *Completions* because none of
    2874             : the commands start with a \"-\" or a SPC."
    2875             :   :version "24.1"
    2876             :   :type 'boolean)
    2877             : 
    2878             : (defun completion-pcm--pattern-trivial-p (pattern)
    2879           0 :   (and (stringp (car pattern))
    2880             :        ;; It can be followed by `point' and "" and still be trivial.
    2881           0 :        (let ((trivial t))
    2882           0 :          (dolist (elem (cdr pattern))
    2883           0 :            (unless (member elem '(point ""))
    2884           0 :              (setq trivial nil)))
    2885           0 :          trivial)))
    2886             : 
    2887             : (defun completion-pcm--string->pattern (string &optional point)
    2888             :   "Split STRING into a pattern.
    2889             : A pattern is a list where each element is either a string
    2890             : or a symbol, see `completion-pcm--merge-completions'."
    2891           0 :   (if (and point (< point (length string)))
    2892           0 :       (let ((prefix (substring string 0 point))
    2893           0 :             (suffix (substring string point)))
    2894           0 :         (append (completion-pcm--string->pattern prefix)
    2895             :                 '(point)
    2896           0 :                 (completion-pcm--string->pattern suffix)))
    2897           0 :     (let* ((pattern nil)
    2898             :            (p 0)
    2899           0 :            (p0 p)
    2900             :            (pending nil))
    2901             : 
    2902           0 :       (while (and (setq p (string-match completion-pcm--delim-wild-regex
    2903           0 :                                         string p))
    2904           0 :                   (or completion-pcm-complete-word-inserts-delimiters
    2905             :                       ;; If the char was added by minibuffer-complete-word,
    2906             :                       ;; then don't treat it as a delimiter, otherwise
    2907             :                       ;; "M-x SPC" ends up inserting a "-" rather than listing
    2908             :                       ;; all completions.
    2909           0 :                       (not (get-text-property p 'completion-try-word string))))
    2910             :         ;; Usually, completion-pcm--delim-wild-regex matches a delimiter,
    2911             :         ;; meaning that something can be added *before* it, but it can also
    2912             :         ;; match a prefix and postfix, in which case something can be added
    2913             :         ;; in-between (e.g. match [[:lower:]][[:upper:]]).
    2914             :         ;; This is determined by the presence of a submatch-1 which delimits
    2915             :         ;; the prefix.
    2916           0 :         (if (match-end 1) (setq p (match-end 1)))
    2917           0 :         (unless (= p0 p)
    2918           0 :           (if pending (push pending pattern))
    2919           0 :           (push (substring string p0 p) pattern))
    2920           0 :         (setq pending nil)
    2921           0 :         (if (eq (aref string p) ?*)
    2922           0 :             (progn
    2923           0 :               (push 'star pattern)
    2924           0 :               (setq p0 (1+ p)))
    2925           0 :           (push 'any pattern)
    2926           0 :           (if (match-end 1)
    2927           0 :               (setq p0 p)
    2928           0 :             (push (substring string p (match-end 0)) pattern)
    2929             :             ;; `any-delim' is used so that "a-b" also finds "array->beginning".
    2930           0 :             (setq pending 'any-delim)
    2931           0 :             (setq p0 (match-end 0))))
    2932           0 :         (setq p p0))
    2933             : 
    2934           0 :       (when (> (length string) p0)
    2935           0 :         (if pending (push pending pattern))
    2936           0 :         (push (substring string p0) pattern))
    2937             :       ;; An empty string might be erroneously added at the beginning.
    2938             :       ;; It should be avoided properly, but it's so easy to remove it here.
    2939           0 :       (delete "" (nreverse pattern)))))
    2940             : 
    2941             : (defun completion-pcm--optimize-pattern (p)
    2942             :   ;; Remove empty strings in a separate phase since otherwise a ""
    2943             :   ;; might prevent some other optimization, as in '(any "" any).
    2944           0 :   (setq p (delete "" p))
    2945           0 :   (let ((n '()))
    2946           0 :     (while p
    2947           0 :       (pcase p
    2948             :         (`(,(and s1 (pred stringp)) ,(and s2 (pred stringp)) . ,rest)
    2949           0 :          (setq p (cons (concat s1 s2) rest)))
    2950           0 :         (`(,(and p1 (pred symbolp)) ,(and p2 (guard (eq p1 p2))) . ,_)
    2951           0 :          (setq p (cdr p)))
    2952           0 :         (`(star ,(pred symbolp) . ,rest) (setq p `(star . ,rest)))
    2953           0 :         (`(,(pred symbolp) star . ,rest) (setq p `(star . ,rest)))
    2954           0 :         (`(point ,(or `any `any-delim) . ,rest) (setq p `(point . ,rest)))
    2955           0 :         (`(,(or `any `any-delim) point . ,rest) (setq p `(point . ,rest)))
    2956           0 :         (`(any ,(or `any `any-delim) . ,rest) (setq p `(any . ,rest)))
    2957           0 :         (`(,(pred symbolp)) (setq p nil)) ;Implicit terminating `any'.
    2958           0 :         (_ (push (pop p) n))))
    2959           0 :     (nreverse n)))
    2960             : 
    2961             : (defun completion-pcm--pattern->regex (pattern &optional group)
    2962           0 :   (let ((re
    2963           0 :          (concat "\\`"
    2964           0 :                  (mapconcat
    2965             :                   (lambda (x)
    2966           0 :                     (cond
    2967           0 :                      ((stringp x) (regexp-quote x))
    2968             :                      (t
    2969           0 :                       (let ((re (if (eq x 'any-delim)
    2970           0 :                                     (concat completion-pcm--delim-wild-regex "*?")
    2971           0 :                                   ".*?")))
    2972           0 :                         (if (if (consp group) (memq x group) group)
    2973           0 :                             (concat "\\(" re "\\)")
    2974           0 :                           re)))))
    2975           0 :                   pattern
    2976           0 :                   ""))))
    2977             :     ;; Avoid pathological backtracking.
    2978           0 :     (while (string-match "\\.\\*\\?\\(?:\\\\[()]\\)*\\(\\.\\*\\?\\)" re)
    2979           0 :       (setq re (replace-match "" t t re 1)))
    2980           0 :     re))
    2981             : 
    2982             : (defun completion-pcm--all-completions (prefix pattern table pred)
    2983             :   "Find all completions for PATTERN in TABLE obeying PRED.
    2984             : PATTERN is as returned by `completion-pcm--string->pattern'."
    2985             :   ;; (cl-assert (= (car (completion-boundaries prefix table pred ""))
    2986             :   ;;            (length prefix)))
    2987             :   ;; Find an initial list of possible completions.
    2988           0 :   (if (completion-pcm--pattern-trivial-p pattern)
    2989             : 
    2990             :       ;; Minibuffer contains no delimiters -- simple case!
    2991           0 :       (all-completions (concat prefix (car pattern)) table pred)
    2992             : 
    2993             :     ;; Use all-completions to do an initial cull.  This is a big win,
    2994             :     ;; since all-completions is written in C!
    2995           0 :     (let* (;; Convert search pattern to a standard regular expression.
    2996           0 :            (regex (completion-pcm--pattern->regex pattern))
    2997           0 :            (case-fold-search completion-ignore-case)
    2998           0 :            (completion-regexp-list (cons regex completion-regexp-list))
    2999           0 :            (compl (all-completions
    3000           0 :                    (concat prefix
    3001           0 :                            (if (stringp (car pattern)) (car pattern) ""))
    3002           0 :                    table pred)))
    3003           0 :       (if (not (functionp table))
    3004             :           ;; The internal functions already obeyed completion-regexp-list.
    3005           0 :           compl
    3006           0 :         (let ((poss ()))
    3007           0 :           (dolist (c compl)
    3008           0 :             (when (string-match-p regex c) (push c poss)))
    3009           0 :           (nreverse poss))))))
    3010             : 
    3011             : (defun completion-pcm--hilit-commonality (pattern completions)
    3012           0 :   (when completions
    3013           0 :     (let* ((re (completion-pcm--pattern->regex pattern '(point)))
    3014           0 :            (case-fold-search completion-ignore-case))
    3015           0 :       (mapcar
    3016             :        (lambda (str)
    3017             :          ;; Don't modify the string itself.
    3018           0 :          (setq str (copy-sequence str))
    3019           0 :          (unless (string-match re str)
    3020           0 :            (error "Internal error: %s does not match %s" re str))
    3021           0 :          (let ((pos (or (match-beginning 1) (match-end 0))))
    3022           0 :            (put-text-property 0 pos
    3023             :                               'font-lock-face 'completions-common-part
    3024           0 :                               str)
    3025           0 :            (if (> (length str) pos)
    3026           0 :                (put-text-property pos (1+ pos)
    3027             :                                   'font-lock-face 'completions-first-difference
    3028           0 :                                   str)))
    3029           0 :          str)
    3030           0 :        completions))))
    3031             : 
    3032             : (defun completion-pcm--find-all-completions (string table pred point
    3033             :                                                     &optional filter)
    3034             :   "Find all completions for STRING at POINT in TABLE, satisfying PRED.
    3035             : POINT is a position inside STRING.
    3036             : FILTER is a function applied to the return value, that can be used, e.g. to
    3037             : filter out additional entries (because TABLE might not obey PRED)."
    3038           0 :   (unless filter (setq filter 'identity))
    3039           0 :   (let* ((beforepoint (substring string 0 point))
    3040           0 :          (afterpoint (substring string point))
    3041           0 :          (bounds (completion-boundaries beforepoint table pred afterpoint))
    3042           0 :          (prefix (substring beforepoint 0 (car bounds)))
    3043           0 :          (suffix (substring afterpoint (cdr bounds)))
    3044             :          firsterror)
    3045           0 :     (setq string (substring string (car bounds) (+ point (cdr bounds))))
    3046           0 :     (let* ((relpoint (- point (car bounds)))
    3047           0 :            (pattern (completion-pcm--string->pattern string relpoint))
    3048           0 :            (all (condition-case-unless-debug err
    3049           0 :                     (funcall filter
    3050           0 :                              (completion-pcm--all-completions
    3051           0 :                               prefix pattern table pred))
    3052           0 :                   (error (setq firsterror err) nil))))
    3053           0 :       (when (and (null all)
    3054           0 :                  (> (car bounds) 0)
    3055           0 :                  (null (ignore-errors (try-completion prefix table pred))))
    3056             :         ;; The prefix has no completions at all, so we should try and fix
    3057             :         ;; that first.
    3058           0 :         (let ((substring (substring prefix 0 -1)))
    3059           0 :           (pcase-let ((`(,subpat ,suball ,subprefix ,_subsuffix)
    3060           0 :                        (completion-pcm--find-all-completions
    3061           0 :                         substring table pred (length substring) filter)))
    3062           0 :             (let ((sep (aref prefix (1- (length prefix))))
    3063             :                   ;; Text that goes between the new submatches and the
    3064             :                   ;; completion substring.
    3065             :                   (between nil))
    3066             :               ;; Eliminate submatches that don't end with the separator.
    3067           0 :               (dolist (submatch (prog1 suball (setq suball ())))
    3068           0 :                 (when (eq sep (aref submatch (1- (length submatch))))
    3069           0 :                   (push submatch suball)))
    3070           0 :               (when suball
    3071             :                 ;; Update the boundaries and corresponding pattern.
    3072             :                 ;; We assume that all submatches result in the same boundaries
    3073             :                 ;; since we wouldn't know how to merge them otherwise anyway.
    3074             :                 ;; FIXME: COMPLETE REWRITE!!!
    3075           0 :                 (let* ((newbeforepoint
    3076           0 :                         (concat subprefix (car suball)
    3077           0 :                                 (substring string 0 relpoint)))
    3078           0 :                        (leftbound (+ (length subprefix) (length (car suball))))
    3079           0 :                        (newbounds (completion-boundaries
    3080           0 :                                    newbeforepoint table pred afterpoint)))
    3081           0 :                   (unless (or (and (eq (cdr bounds) (cdr newbounds))
    3082           0 :                                    (eq (car newbounds) leftbound))
    3083             :                               ;; Refuse new boundaries if they step over
    3084             :                               ;; the submatch.
    3085           0 :                               (< (car newbounds) leftbound))
    3086             :                     ;; The new completed prefix does change the boundaries
    3087             :                     ;; of the completed substring.
    3088           0 :                     (setq suffix (substring afterpoint (cdr newbounds)))
    3089           0 :                     (setq string
    3090           0 :                           (concat (substring newbeforepoint (car newbounds))
    3091           0 :                                   (substring afterpoint 0 (cdr newbounds))))
    3092           0 :                     (setq between (substring newbeforepoint leftbound
    3093           0 :                                              (car newbounds)))
    3094           0 :                     (setq pattern (completion-pcm--string->pattern
    3095           0 :                                    string
    3096           0 :                                    (- (length newbeforepoint)
    3097           0 :                                       (car newbounds)))))
    3098           0 :                   (dolist (submatch suball)
    3099           0 :                     (setq all (nconc
    3100           0 :                                (mapcar
    3101           0 :                                 (lambda (s) (concat submatch between s))
    3102           0 :                                 (funcall filter
    3103           0 :                                          (completion-pcm--all-completions
    3104           0 :                                           (concat subprefix submatch between)
    3105           0 :                                           pattern table pred)))
    3106           0 :                                all)))
    3107             :                   ;; FIXME: This can come in handy for try-completion,
    3108             :                   ;; but isn't right for all-completions, since it lists
    3109             :                   ;; invalid completions.
    3110             :                   ;; (unless all
    3111             :                   ;;   ;; Even though we found expansions in the prefix, none
    3112             :                   ;;   ;; leads to a valid completion.
    3113             :                   ;;   ;; Let's keep the expansions, tho.
    3114             :                   ;;   (dolist (submatch suball)
    3115             :                   ;;     (push (concat submatch between newsubstring) all)))
    3116           0 :                   ))
    3117           0 :               (setq pattern (append subpat (list 'any (string sep))
    3118           0 :                                     (if between (list between)) pattern))
    3119           0 :               (setq prefix subprefix)))))
    3120           0 :       (if (and (null all) firsterror)
    3121           0 :           (signal (car firsterror) (cdr firsterror))
    3122           0 :         (list pattern all prefix suffix)))))
    3123             : 
    3124             : (defun completion-pcm-all-completions (string table pred point)
    3125           0 :   (pcase-let ((`(,pattern ,all ,prefix ,_suffix)
    3126           0 :                (completion-pcm--find-all-completions string table pred point)))
    3127           0 :     (when all
    3128           0 :       (nconc (completion-pcm--hilit-commonality pattern all)
    3129           0 :              (length prefix)))))
    3130             : 
    3131             : (defun completion--common-suffix (strs)
    3132             :   "Return the common suffix of the strings STRS."
    3133           0 :   (nreverse (try-completion "" (mapcar #'reverse strs))))
    3134             : 
    3135             : (defun completion-pcm--merge-completions (strs pattern)
    3136             :   "Extract the commonality in STRS, with the help of PATTERN.
    3137             : PATTERN can contain strings and symbols chosen among `star', `any', `point',
    3138             : and `prefix'.  They all match anything (aka \".*\") but are merged differently:
    3139             : `any' only grows from the left (when matching \"a1b\" and \"a2b\" it gets
    3140             :   completed to just \"a\").
    3141             : `prefix' only grows from the right (when matching \"a1b\" and \"a2b\" it gets
    3142             :   completed to just \"b\").
    3143             : `star' grows from both ends and is reified into a \"*\"  (when matching \"a1b\"
    3144             :   and \"a2b\" it gets completed to \"a*b\").
    3145             : `point' is like `star' except that it gets reified as the position of point
    3146             :   instead of being reified as a \"*\" character.
    3147             : The underlying idea is that we should return a string which still matches
    3148             : the same set of elements."
    3149             :   ;; When completing while ignoring case, we want to try and avoid
    3150             :   ;; completing "fo" to "foO" when completing against "FOO" (bug#4219).
    3151             :   ;; So we try and make sure that the string we return is all made up
    3152             :   ;; of text from the completions rather than part from the
    3153             :   ;; completions and part from the input.
    3154             :   ;; FIXME: This reduces the problems of inconsistent capitalization
    3155             :   ;; but it doesn't fully fix it: we may still end up completing
    3156             :   ;; "fo-ba" to "foo-BAR" or "FOO-bar" when completing against
    3157             :   ;; '("foo-barr" "FOO-BARD").
    3158           0 :   (cond
    3159           0 :    ((null (cdr strs)) (list (car strs)))
    3160             :    (t
    3161           0 :     (let ((re (completion-pcm--pattern->regex pattern 'group))
    3162             :           (ccs ()))                     ;Chopped completions.
    3163             : 
    3164             :       ;; First chop each string into the parts corresponding to each
    3165             :       ;; non-constant element of `pattern', using regexp-matching.
    3166           0 :       (let ((case-fold-search completion-ignore-case))
    3167           0 :         (dolist (str strs)
    3168           0 :           (unless (string-match re str)
    3169           0 :             (error "Internal error: %s doesn't match %s" str re))
    3170           0 :           (let ((chopped ())
    3171             :                 (last 0)
    3172             :                 (i 1)
    3173             :                 next)
    3174           0 :             (while (setq next (match-end i))
    3175           0 :               (push (substring str last next) chopped)
    3176           0 :               (setq last next)
    3177           0 :               (setq i (1+ i)))
    3178             :             ;; Add the text corresponding to the implicit trailing `any'.
    3179           0 :             (push (substring str last) chopped)
    3180           0 :             (push (nreverse chopped) ccs))))
    3181             : 
    3182             :       ;; Then for each of those non-constant elements, extract the
    3183             :       ;; commonality between them.
    3184           0 :       (let ((res ())
    3185             :             (fixed ""))
    3186             :         ;; Make the implicit trailing `any' explicit.
    3187           0 :         (dolist (elem (append pattern '(any)))
    3188           0 :           (if (stringp elem)
    3189           0 :               (setq fixed (concat fixed elem))
    3190           0 :             (let ((comps ()))
    3191           0 :               (dolist (cc (prog1 ccs (setq ccs nil)))
    3192           0 :                 (push (car cc) comps)
    3193           0 :                 (push (cdr cc) ccs))
    3194             :               ;; Might improve the likelihood to avoid choosing
    3195             :               ;; different capitalizations in different parts.
    3196             :               ;; In practice, it doesn't seem to make any difference.
    3197           0 :               (setq ccs (nreverse ccs))
    3198           0 :               (let* ((prefix (try-completion fixed comps))
    3199           0 :                      (unique (or (and (eq prefix t) (setq prefix fixed))
    3200           0 :                                  (eq t (try-completion prefix comps)))))
    3201           0 :                 (unless (or (eq elem 'prefix)
    3202           0 :                             (equal prefix ""))
    3203           0 :                   (push prefix res))
    3204             :                 ;; If there's only one completion, `elem' is not useful
    3205             :                 ;; any more: it can only match the empty string.
    3206             :                 ;; FIXME: in some cases, it may be necessary to turn an
    3207             :                 ;; `any' into a `star' because the surrounding context has
    3208             :                 ;; changed such that string->pattern wouldn't add an `any'
    3209             :                 ;; here any more.
    3210           0 :                 (unless unique
    3211           0 :                   (push elem res)
    3212             :                   ;; Extract common suffix additionally to common prefix.
    3213             :                   ;; Don't do it for `any' since it could lead to a merged
    3214             :                   ;; completion that doesn't itself match the candidates.
    3215           0 :                   (when (and (memq elem '(star point prefix))
    3216             :                              ;; If prefix is one of the completions, there's no
    3217             :                              ;; suffix left to find.
    3218           0 :                              (not (assoc-string prefix comps t)))
    3219           0 :                     (let ((suffix
    3220           0 :                            (completion--common-suffix
    3221           0 :                             (if (zerop (length prefix)) comps
    3222             :                               ;; Ignore the chars in the common prefix, so we
    3223             :                               ;; don't merge '("abc" "abbc") as "ab*bc".
    3224           0 :                               (let ((skip (length prefix)))
    3225           0 :                                 (mapcar (lambda (str) (substring str skip))
    3226           0 :                                         comps))))))
    3227           0 :                       (cl-assert (stringp suffix))
    3228           0 :                       (unless (equal suffix "")
    3229           0 :                         (push suffix res)))))
    3230           0 :                 (setq fixed "")))))
    3231             :         ;; We return it in reverse order.
    3232           0 :         res)))))
    3233             : 
    3234             : (defun completion-pcm--pattern->string (pattern)
    3235           0 :   (mapconcat (lambda (x) (cond
    3236           0 :                           ((stringp x) x)
    3237           0 :                           ((eq x 'star) "*")
    3238           0 :                           (t "")))           ;any, point, prefix.
    3239           0 :              pattern
    3240           0 :              ""))
    3241             : 
    3242             : ;; We want to provide the functionality of `try', but we use `all'
    3243             : ;; and then merge it.  In most cases, this works perfectly, but
    3244             : ;; if the completion table doesn't consider the same completions in
    3245             : ;; `try' as in `all', then we have a problem.  The most common such
    3246             : ;; case is for filename completion where completion-ignored-extensions
    3247             : ;; is only obeyed by the `try' code.  We paper over the difference
    3248             : ;; here.  Note that it is not quite right either: if the completion
    3249             : ;; table uses completion-table-in-turn, this filtering may take place
    3250             : ;; too late to correctly fallback from the first to the
    3251             : ;; second alternative.
    3252             : (defun completion-pcm--filename-try-filter (all)
    3253             :   "Filter to adjust `all' file completion to the behavior of `try'."
    3254           0 :   (when all
    3255           0 :     (let ((try ())
    3256           0 :           (re (concat "\\(?:\\`\\.\\.?/\\|"
    3257           0 :                       (regexp-opt completion-ignored-extensions)
    3258           0 :                       "\\)\\'")))
    3259           0 :       (dolist (f all)
    3260           0 :         (unless (string-match-p re f) (push f try)))
    3261           0 :       (or (nreverse try) all))))
    3262             : 
    3263             : 
    3264             : (defun completion-pcm--merge-try (pattern all prefix suffix)
    3265           0 :   (cond
    3266           0 :    ((not (consp all)) all)
    3267           0 :    ((and (not (consp (cdr all)))        ;Only one completion.
    3268             :          ;; Ignore completion-ignore-case here.
    3269           0 :          (equal (completion-pcm--pattern->string pattern) (car all)))
    3270             :     t)
    3271             :    (t
    3272           0 :     (let* ((mergedpat (completion-pcm--merge-completions all pattern))
    3273             :            ;; `mergedpat' is in reverse order.  Place new point (by
    3274             :            ;; order of preference) either at the old point, or at
    3275             :            ;; the last place where there's something to choose, or
    3276             :            ;; at the very end.
    3277           0 :            (pointpat (or (memq 'point mergedpat)
    3278           0 :                          (memq 'any   mergedpat)
    3279           0 :                          (memq 'star  mergedpat)
    3280             :                          ;; Not `prefix'.
    3281           0 :                          mergedpat))
    3282             :            ;; New pos from the start.
    3283           0 :            (newpos (length (completion-pcm--pattern->string pointpat)))
    3284             :            ;; Do it afterwards because it changes `pointpat' by side effect.
    3285           0 :            (merged (completion-pcm--pattern->string (nreverse mergedpat))))
    3286             : 
    3287           0 :       (setq suffix (completion--merge-suffix
    3288             :                     ;; The second arg should ideally be "the position right
    3289             :                     ;; after the last char of `merged' that comes from the text
    3290             :                     ;; to be completed".  But completion-pcm--merge-completions
    3291             :                     ;; currently doesn't give us that info.  So instead we just
    3292             :                     ;; use the "last but one" position, which tends to work
    3293             :                     ;; well in practice since `suffix' always starts
    3294             :                     ;; with a boundary and we hence mostly/only care about
    3295             :                     ;; merging this boundary (bug#15419).
    3296           0 :                     merged (max 0 (1- (length merged))) suffix))
    3297           0 :       (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
    3298             : 
    3299             : (defun completion-pcm-try-completion (string table pred point)
    3300           0 :   (pcase-let ((`(,pattern ,all ,prefix ,suffix)
    3301           0 :                (completion-pcm--find-all-completions
    3302           0 :                 string table pred point
    3303           0 :                 (if minibuffer-completing-file-name
    3304           0 :                     'completion-pcm--filename-try-filter))))
    3305           0 :     (completion-pcm--merge-try pattern all prefix suffix)))
    3306             : 
    3307             : ;;; Substring completion
    3308             : ;; Mostly derived from the code of `basic' completion.
    3309             : 
    3310             : (defun completion-substring--all-completions (string table pred point)
    3311           0 :   (let* ((beforepoint (substring string 0 point))
    3312           0 :          (afterpoint (substring string point))
    3313           0 :          (bounds (completion-boundaries beforepoint table pred afterpoint))
    3314           0 :          (suffix (substring afterpoint (cdr bounds)))
    3315           0 :          (prefix (substring beforepoint 0 (car bounds)))
    3316           0 :          (basic-pattern (completion-basic--pattern
    3317           0 :                          beforepoint afterpoint bounds))
    3318           0 :          (pattern (if (not (stringp (car basic-pattern)))
    3319           0 :                       basic-pattern
    3320           0 :                     (cons 'prefix basic-pattern)))
    3321           0 :          (all (completion-pcm--all-completions prefix pattern table pred)))
    3322           0 :     (list all pattern prefix suffix (car bounds))))
    3323             : 
    3324             : (defun completion-substring-try-completion (string table pred point)
    3325           0 :   (pcase-let ((`(,all ,pattern ,prefix ,suffix ,_carbounds)
    3326           0 :                (completion-substring--all-completions
    3327           0 :                 string table pred point)))
    3328           0 :     (if minibuffer-completing-file-name
    3329           0 :         (setq all (completion-pcm--filename-try-filter all)))
    3330           0 :     (completion-pcm--merge-try pattern all prefix suffix)))
    3331             : 
    3332             : (defun completion-substring-all-completions (string table pred point)
    3333           0 :   (pcase-let ((`(,all ,pattern ,prefix ,_suffix ,_carbounds)
    3334           0 :                (completion-substring--all-completions
    3335           0 :                 string table pred point)))
    3336           0 :     (when all
    3337           0 :       (nconc (completion-pcm--hilit-commonality pattern all)
    3338           0 :              (length prefix)))))
    3339             : 
    3340             : ;; Initials completion
    3341             : ;; Complete /ums to /usr/monnier/src or lch to list-command-history.
    3342             : 
    3343             : (defun completion-initials-expand (str table pred)
    3344           0 :   (let ((bounds (completion-boundaries str table pred "")))
    3345           0 :     (unless (or (zerop (length str))
    3346             :                 ;; Only check within the boundaries, since the
    3347             :                 ;; boundary char (e.g. /) might be in delim-regexp.
    3348           0 :                 (string-match completion-pcm--delim-wild-regex str
    3349           0 :                               (car bounds)))
    3350           0 :       (if (zerop (car bounds))
    3351             :           ;; FIXME: Don't hardcode "-" (bug#17559).
    3352           0 :           (mapconcat 'string str "-")
    3353             :         ;; If there's a boundary, it's trickier.  The main use-case
    3354             :         ;; we consider here is file-name completion.  We'd like
    3355             :         ;; to expand ~/eee to ~/e/e/e and /eee to /e/e/e.
    3356             :         ;; But at the same time, we don't want /usr/share/ae to expand
    3357             :         ;; to /usr/share/a/e just because we mistyped "ae" for "ar",
    3358             :         ;; so we probably don't want initials to touch anything that
    3359             :         ;; looks like /usr/share/foo.  As a heuristic, we just check that
    3360             :         ;; the text before the boundary char is at most 1 char.
    3361             :         ;; This allows both ~/eee and /eee and not much more.
    3362             :         ;; FIXME: It sadly also disallows the use of ~/eee when that's
    3363             :         ;; embedded within something else (e.g. "(~/eee" in Info node
    3364             :         ;; completion or "ancestor:/eee" in bzr-revision completion).
    3365           0 :         (when (< (car bounds) 3)
    3366           0 :           (let ((sep (substring str (1- (car bounds)) (car bounds))))
    3367             :             ;; FIXME: the above string-match checks the whole string, whereas
    3368             :             ;; we end up only caring about the after-boundary part.
    3369           0 :             (concat (substring str 0 (car bounds))
    3370           0 :                     (mapconcat 'string (substring str (car bounds)) sep))))))))
    3371             : 
    3372             : (defun completion-initials-all-completions (string table pred _point)
    3373           0 :   (let ((newstr (completion-initials-expand string table pred)))
    3374           0 :     (when newstr
    3375           0 :       (completion-pcm-all-completions newstr table pred (length newstr)))))
    3376             : 
    3377             : (defun completion-initials-try-completion (string table pred _point)
    3378           0 :   (let ((newstr (completion-initials-expand string table pred)))
    3379           0 :     (when newstr
    3380           0 :       (completion-pcm-try-completion newstr table pred (length newstr)))))
    3381             : 
    3382             : (defvar completing-read-function 'completing-read-default
    3383             :   "The function called by `completing-read' to do its work.
    3384             : It should accept the same arguments as `completing-read'.")
    3385             : 
    3386             : (defun completing-read-default (prompt collection &optional predicate
    3387             :                                        require-match initial-input
    3388             :                                        hist def inherit-input-method)
    3389             :   "Default method for reading from the minibuffer with completion.
    3390             : See `completing-read' for the meaning of the arguments."
    3391             : 
    3392           0 :   (when (consp initial-input)
    3393           0 :     (setq initial-input
    3394           0 :           (cons (car initial-input)
    3395             :                 ;; `completing-read' uses 0-based index while
    3396             :                 ;; `read-from-minibuffer' uses 1-based index.
    3397           0 :                 (1+ (cdr initial-input)))))
    3398             : 
    3399           0 :   (let* ((minibuffer-completion-table collection)
    3400           0 :          (minibuffer-completion-predicate predicate)
    3401           0 :          (minibuffer-completion-confirm (unless (eq require-match t)
    3402           0 :                                           require-match))
    3403           0 :          (base-keymap (if require-match
    3404           0 :                          minibuffer-local-must-match-map
    3405           0 :                         minibuffer-local-completion-map))
    3406           0 :          (keymap (if (memq minibuffer-completing-file-name '(nil lambda))
    3407           0 :                      base-keymap
    3408             :                    ;; Layer minibuffer-local-filename-completion-map
    3409             :                    ;; on top of the base map.
    3410           0 :                    (make-composed-keymap
    3411           0 :                     minibuffer-local-filename-completion-map
    3412             :                     ;; Set base-keymap as the parent, so that nil bindings
    3413             :                     ;; in minibuffer-local-filename-completion-map can
    3414             :                     ;; override bindings in base-keymap.
    3415           0 :                     base-keymap)))
    3416           0 :          (result (read-from-minibuffer prompt initial-input keymap
    3417           0 :                                        nil hist def inherit-input-method)))
    3418           0 :     (when (and (equal result "") def)
    3419           0 :       (setq result (if (consp def) (car def) def)))
    3420           0 :     result))
    3421             : 
    3422             : ;; Miscellaneous
    3423             : 
    3424             : (defun minibuffer-insert-file-name-at-point ()
    3425             :   "Get a file name at point in original buffer and insert it to minibuffer."
    3426             :   (interactive)
    3427           0 :   (let ((file-name-at-point
    3428           0 :          (with-current-buffer (window-buffer (minibuffer-selected-window))
    3429           0 :            (run-hook-with-args-until-success 'file-name-at-point-functions))))
    3430           0 :     (when file-name-at-point
    3431           0 :       (insert file-name-at-point))))
    3432             : 
    3433             : (provide 'minibuffer)
    3434             : 
    3435             : ;;; minibuffer.el ends here

Generated by: LCOV version 1.12