+ (completion-hilit-commonality
+ (all-completions (substring string 0 point) table pred)
+ point))
+
+;;; Basic completion.
+
+(defun completion--merge-suffix (completion point suffix)
+ "Merge end of COMPLETION with beginning of SUFFIX.
+Simple generalization of the \"merge trailing /\" done in Emacs-22.
+Return the new suffix."
+ (if (and (not (zerop (length suffix)))
+ (string-match "\\(.+\\)\n\\1" (concat completion "\n" suffix)
+ ;; Make sure we don't compress things to less
+ ;; than we started with.
+ point)
+ ;; Just make sure we didn't match some other \n.
+ (eq (match-end 1) (length completion)))
+ (substring suffix (- (match-end 1) (match-beginning 1)))
+ ;; Nothing to merge.
+ suffix))
+
+(defun completion-basic-try-completion (string table pred point)
+ (let* ((beforepoint (substring string 0 point))
+ (afterpoint (substring string point))
+ (bounds (completion-boundaries beforepoint table pred afterpoint)))
+ (if (zerop (cdr bounds))
+ ;; `try-completion' may return a subtly different result
+ ;; than `all+merge', so try to use it whenever possible.
+ (let ((completion (try-completion beforepoint table pred)))
+ (if (not (stringp completion))
+ completion
+ (cons
+ (concat completion
+ (completion--merge-suffix completion point afterpoint))
+ (length completion))))
+ (let* ((suffix (substring afterpoint (cdr bounds)))
+ (prefix (substring beforepoint 0 (car bounds)))
+ (pattern (delete
+ "" (list (substring beforepoint (car bounds))
+ 'point
+ (substring afterpoint 0 (cdr bounds)))))
+ (all (completion-pcm--all-completions prefix pattern table pred)))
+ (if minibuffer-completing-file-name
+ (setq all (completion-pcm--filename-try-filter all)))
+ (completion-pcm--merge-try pattern all prefix suffix)))))
+
+(defun completion-basic-all-completions (string table pred point)
+ (let* ((beforepoint (substring string 0 point))
+ (afterpoint (substring string point))
+ (bounds (completion-boundaries beforepoint table pred afterpoint))
+ (suffix (substring afterpoint (cdr bounds)))
+ (prefix (substring beforepoint 0 (car bounds)))
+ (pattern (delete
+ "" (list (substring beforepoint (car bounds))
+ 'point
+ (substring afterpoint 0 (cdr bounds)))))
+ (all (completion-pcm--all-completions prefix pattern table pred)))
+ (completion-hilit-commonality
+ (if (consp all) (nconc all (car bounds)) all)
+ point)))
+
+;;; Partial-completion-mode style completion.
+
+(defvar completion-pcm--delim-wild-regex nil)
+
+(defun completion-pcm--prepare-delim-re (delims)
+ (setq completion-pcm--delim-wild-regex (concat "[" delims "*]")))
+
+(defcustom completion-pcm-word-delimiters "-_. "
+ "A string of characters treated as word delimiters for completion.
+Some arcane rules:
+If `]' is in this string, it must come first.
+If `^' is in this string, it must not come first.
+If `-' is in this string, it must come first or right after `]'.
+In other words, if S is this string, then `[S]' must be a valid Emacs regular
+expression (not containing character ranges like `a-z')."
+ :set (lambda (symbol value)
+ (set-default symbol value)
+ ;; Refresh other vars.
+ (completion-pcm--prepare-delim-re value))
+ :initialize 'custom-initialize-reset
+ :group 'minibuffer
+ :type 'string)
+
+(defun completion-pcm--pattern-trivial-p (pattern)
+ (and (stringp (car pattern)) (null (cdr pattern))))
+
+(defun completion-pcm--string->pattern (string &optional point)
+ "Split STRING into a pattern.
+A pattern is a list where each element is either a string
+or a symbol chosen among `any', `star', `point'."
+ (if (and point (< point (length string)))
+ (let ((prefix (substring string 0 point))
+ (suffix (substring string point)))
+ (append (completion-pcm--string->pattern prefix)
+ '(point)
+ (completion-pcm--string->pattern suffix)))
+ (let ((pattern nil)
+ (p 0)
+ (p0 0))
+
+ (while (setq p (string-match completion-pcm--delim-wild-regex string p))
+ (push (substring string p0 p) pattern)
+ (if (eq (aref string p) ?*)
+ (progn
+ (push 'star pattern)
+ (setq p0 (1+ p)))
+ (push 'any pattern)
+ (setq p0 p))
+ (incf p))
+
+ ;; An empty string might be erroneously added at the beginning.
+ ;; It should be avoided properly, but it's so easy to remove it here.
+ (delete "" (nreverse (cons (substring string p0) pattern))))))
+
+(defun completion-pcm--pattern->regex (pattern &optional group)
+ (let ((re
+ (concat "\\`"
+ (mapconcat
+ (lambda (x)
+ (case x
+ ((star any point)
+ (if (if (consp group) (memq x group) group)
+ "\\(.*?\\)" ".*?"))
+ (t (regexp-quote x))))
+ pattern
+ ""))))
+ ;; Avoid pathological backtracking.
+ (while (string-match "\\.\\*\\?\\(?:\\\\[()]\\)*\\(\\.\\*\\?\\)" re)
+ (setq re (replace-match "" t t re 1)))
+ re))
+
+(defun completion-pcm--all-completions (prefix pattern table pred)
+ "Find all completions for PATTERN in TABLE obeying PRED.
+PATTERN is as returned by `completion-pcm--string->pattern'."
+ ;; Find an initial list of possible completions.
+ (if (completion-pcm--pattern-trivial-p pattern)
+
+ ;; Minibuffer contains no delimiters -- simple case!
+ (let* ((all (all-completions (concat prefix (car pattern)) table pred))
+ (last (last all)))
+ (if last (setcdr last nil))
+ all)
+
+ ;; Use all-completions to do an initial cull. This is a big win,
+ ;; since all-completions is written in C!
+ (let* (;; Convert search pattern to a standard regular expression.
+ (regex (completion-pcm--pattern->regex pattern))
+ (case-fold-search completion-ignore-case)
+ (completion-regexp-list (cons regex completion-regexp-list))
+ (compl (all-completions
+ (concat prefix (if (stringp (car pattern)) (car pattern) ""))
+ table pred))
+ (last (last compl)))
+ (when last
+ (if (and (numberp (cdr last)) (/= (cdr last) (length prefix)))
+ (message "Inconsistent base-size returned by completion table %s"
+ table))
+ (setcdr last nil))
+ (if (not (functionp table))
+ ;; The internal functions already obeyed completion-regexp-list.
+ compl
+ (let ((poss ()))
+ (dolist (c compl)
+ (when (string-match regex c) (push c poss)))
+ poss)))))
+
+(defun completion-pcm--hilit-commonality (pattern completions)
+ (when completions
+ (let* ((re (completion-pcm--pattern->regex pattern '(point)))
+ (case-fold-search completion-ignore-case)
+ (last (last completions))
+ (base-size (cdr last)))
+ ;; Remove base-size during mapcar, and add it back later.
+ (setcdr last nil)
+ (nconc
+ (mapcar
+ (lambda (str)
+ ;; Don't modify the string itself.
+ (setq str (copy-sequence str))
+ (unless (string-match re str)
+ (error "Internal error: %s does not match %s" re str))
+ (let ((pos (or (match-beginning 1) (match-end 0))))
+ (put-text-property 0 pos
+ 'font-lock-face 'completions-common-part
+ str)
+ (if (> (length str) pos)
+ (put-text-property pos (1+ pos)
+ 'font-lock-face 'completions-first-difference
+ str)))
+ str)
+ completions)
+ base-size))))
+
+(defun completion-pcm--find-all-completions (string table pred point
+ &optional filter)
+ "Find all completions for STRING at POINT in TABLE, satisfying PRED.
+POINT is a position inside STRING.
+FILTER is a function applied to the return value, that can be used, e.g. to
+filter out additional entries (because TABLE migth not obey PRED)."
+ (unless filter (setq filter 'identity))
+ (let* ((beforepoint (substring string 0 point))
+ (afterpoint (substring string point))
+ (bounds (completion-boundaries beforepoint table pred afterpoint))
+ (prefix (substring beforepoint 0 (car bounds)))
+ (suffix (substring afterpoint (cdr bounds)))
+ firsterror)
+ (setq string (substring string (car bounds) (+ point (cdr bounds))))
+ (let* ((relpoint (- point (car bounds)))
+ (pattern (completion-pcm--string->pattern string relpoint))
+ (all (condition-case err
+ (funcall filter
+ (completion-pcm--all-completions
+ prefix pattern table pred))
+ (error (unless firsterror (setq firsterror err)) nil))))
+ (when (and (null all)
+ (> (car bounds) 0)
+ (null (ignore-errors (try-completion prefix table pred))))
+ ;; The prefix has no completions at all, so we should try and fix
+ ;; that first.
+ (let ((substring (substring prefix 0 -1)))
+ (destructuring-bind (subpat suball subprefix subsuffix)
+ (completion-pcm--find-all-completions
+ substring table pred (length substring) filter)
+ (let ((sep (aref prefix (1- (length prefix))))
+ ;; Text that goes between the new submatches and the
+ ;; completion substring.
+ (between nil))
+ ;; Eliminate submatches that don't end with the separator.
+ (dolist (submatch (prog1 suball (setq suball ())))
+ (when (eq sep (aref submatch (1- (length submatch))))
+ (push submatch suball)))
+ (when suball
+ ;; Update the boundaries and corresponding pattern.
+ ;; We assume that all submatches result in the same boundaries
+ ;; since we wouldn't know how to merge them otherwise anyway.
+ ;; FIXME: COMPLETE REWRITE!!!
+ (let* ((newbeforepoint
+ (concat subprefix (car suball)
+ (substring string 0 relpoint)))
+ (leftbound (+ (length subprefix) (length (car suball))))
+ (newbounds (completion-boundaries
+ newbeforepoint table pred afterpoint)))
+ (unless (or (and (eq (cdr bounds) (cdr newbounds))
+ (eq (car newbounds) leftbound))
+ ;; Refuse new boundaries if they step over
+ ;; the submatch.
+ (< (car newbounds) leftbound))
+ ;; The new completed prefix does change the boundaries
+ ;; of the completed substring.
+ (setq suffix (substring afterpoint (cdr newbounds)))
+ (setq string
+ (concat (substring newbeforepoint (car newbounds))
+ (substring afterpoint 0 (cdr newbounds))))
+ (setq between (substring newbeforepoint leftbound
+ (car newbounds)))
+ (setq pattern (completion-pcm--string->pattern
+ string
+ (- (length newbeforepoint)
+ (car newbounds)))))
+ (dolist (submatch suball)
+ (setq all (nconc (mapcar
+ (lambda (s) (concat submatch between s))
+ (funcall filter
+ (completion-pcm--all-completions
+ (concat subprefix submatch between)
+ pattern table pred)))
+ all)))
+ ;; FIXME: This can come in handy for try-completion,
+ ;; but isn't right for all-completions, since it lists
+ ;; invalid completions.
+ ;; (unless all
+ ;; ;; Even though we found expansions in the prefix, none
+ ;; ;; leads to a valid completion.
+ ;; ;; Let's keep the expansions, tho.
+ ;; (dolist (submatch suball)
+ ;; (push (concat submatch between newsubstring) all)))
+ ))
+ (setq pattern (append subpat (list 'any (string sep))
+ (if between (list between)) pattern))
+ (setq prefix subprefix)))))
+ (if (and (null all) firsterror)
+ (signal (car firsterror) (cdr firsterror))
+ (list pattern all prefix suffix)))))
+
+(defun completion-pcm-all-completions (string table pred point)
+ (destructuring-bind (pattern all &optional prefix suffix)
+ (completion-pcm--find-all-completions string table pred point)
+ (when all
+ (nconc (completion-pcm--hilit-commonality pattern all)
+ (length prefix)))))
+
+(defun completion-pcm--merge-completions (strs pattern)
+ "Extract the commonality in STRS, with the help of PATTERN."
+ (cond
+ ((null (cdr strs)) (list (car strs)))
+ (t
+ (let ((re (completion-pcm--pattern->regex pattern 'group))
+ (ccs ())) ;Chopped completions.
+
+ ;; First chop each string into the parts corresponding to each
+ ;; non-constant element of `pattern', using regexp-matching.
+ (let ((case-fold-search completion-ignore-case))
+ (dolist (str strs)
+ (unless (string-match re str)
+ (error "Internal error: %s doesn't match %s" str re))
+ (let ((chopped ())
+ (i 1))
+ (while (match-beginning i)
+ (push (match-string i str) chopped)
+ (setq i (1+ i)))
+ ;; Add the text corresponding to the implicit trailing `any'.
+ (push (substring str (match-end 0)) chopped)
+ (push (nreverse chopped) ccs))))
+
+ ;; Then for each of those non-constant elements, extract the
+ ;; commonality between them.
+ (let ((res ()))
+ ;; Make the implicit `any' explicit. We could make it explicit
+ ;; everywhere, but it would slow down regexp-matching a little bit.
+ (dolist (elem (append pattern '(any)))
+ (if (stringp elem)
+ (push elem res)
+ (let ((comps ()))
+ (dolist (cc (prog1 ccs (setq ccs nil)))
+ (push (car cc) comps)
+ (push (cdr cc) ccs))
+ (let* ((prefix (try-completion "" comps))
+ (unique (or (and (eq prefix t) (setq prefix ""))
+ (eq t (try-completion prefix comps)))))
+ (unless (equal prefix "") (push prefix res))
+ ;; If there's only one completion, `elem' is not useful
+ ;; any more: it can only match the empty string.
+ ;; FIXME: in some cases, it may be necessary to turn an
+ ;; `any' into a `star' because the surrounding context has
+ ;; changed such that string->pattern wouldn't add an `any'
+ ;; here any more.
+ (unless unique (push elem res))))))
+ ;; We return it in reverse order.
+ res)))))
+
+(defun completion-pcm--pattern->string (pattern)
+ (mapconcat (lambda (x) (cond
+ ((stringp x) x)
+ ((eq x 'star) "*")
+ ((eq x 'any) "")
+ ((eq x 'point) "")))
+ pattern
+ ""))
+
+;; We want to provide the functionality of `try', but we use `all'
+;; and then merge it. In most cases, this works perfectly, but
+;; if the completion table doesn't consider the same completions in
+;; `try' as in `all', then we have a problem. The most common such
+;; case is for filename completion where completion-ignored-extensions
+;; is only obeyed by the `try' code. We paper over the difference
+;; here. Note that it is not quite right either: if the completion
+;; table uses completion-table-in-turn, this filtering may take place
+;; too late to correctly fallback from the first to the
+;; second alternative.
+(defun completion-pcm--filename-try-filter (all)
+ "Filter to adjust `all' file completion to the behavior of `try'."
+ (when all
+ (let ((try ())
+ (re (concat "\\(?:\\`\\.\\.?/\\|"
+ (regexp-opt completion-ignored-extensions)
+ "\\)\\'")))
+ (dolist (f all)
+ (unless (string-match re f) (push f try)))
+ (or try all))))
+
+
+(defun completion-pcm--merge-try (pattern all prefix suffix)
+ (cond
+ ((not (consp all)) all)
+ ((and (not (consp (cdr all))) ;Only one completion.
+ ;; Ignore completion-ignore-case here.
+ (equal (completion-pcm--pattern->string pattern) (car all)))
+ t)
+ (t
+ (let* ((mergedpat (completion-pcm--merge-completions all pattern))
+ ;; `mergedpat' is in reverse order. Place new point (by
+ ;; order of preference) either at the old point, or at
+ ;; the last place where there's something to choose, or
+ ;; at the very end.
+ (pointpat (or (memq 'point mergedpat) (memq 'any mergedpat)
+ mergedpat))
+ ;; New pos from the start.
+ (newpos (length (completion-pcm--pattern->string pointpat)))
+ ;; Do it afterwards because it changes `pointpat' by sideeffect.
+ (merged (completion-pcm--pattern->string (nreverse mergedpat))))
+
+ (setq suffix (completion--merge-suffix merged newpos suffix))
+ (cons (concat prefix merged suffix) (+ newpos (length prefix)))))))
+
+(defun completion-pcm-try-completion (string table pred point)
+ (destructuring-bind (pattern all prefix suffix)
+ (completion-pcm--find-all-completions
+ string table pred point
+ (if minibuffer-completing-file-name
+ 'completion-pcm--filename-try-filter))
+ (completion-pcm--merge-try pattern all prefix suffix)))