X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/fec2107c58835163dc3b08c0a833a5072aa1fca9..refs/heads/wip:/lisp/pcomplete.el diff --git a/lisp/pcomplete.el b/lisp/pcomplete.el index 932436df8c..dbeefda767 100644 --- a/lisp/pcomplete.el +++ b/lisp/pcomplete.el @@ -1,6 +1,6 @@ -;;; pcomplete.el --- programmable completion +;;; pcomplete.el --- programmable completion -*- lexical-binding: t -*- -;; Copyright (C) 1999-2011 Free Software Foundation, Inc. +;; Copyright (C) 1999-2014 Free Software Foundation, Inc. ;; Author: John Wiegley ;; Keywords: processes abbrev @@ -28,7 +28,7 @@ ;; argument position. ;; ;; To use pcomplete with shell-mode, for example, you will need the -;; following in your .emacs file: +;; following in your init file: ;; ;; (add-hook 'shell-mode-hook 'pcomplete-shell-setup) ;; @@ -118,7 +118,7 @@ ;;; Code: -(eval-when-compile (require 'cl)) +(require 'comint) (defgroup pcomplete nil "Programmable completion." @@ -154,6 +154,7 @@ This mirrors the optional behavior of tcsh." "A list of characters which constitute a proper suffix." :type '(repeat character) :group 'pcomplete) +(make-obsolete-variable 'pcomplete-suffix-list nil "24.1") (defcustom pcomplete-recexact nil "If non-nil, use shortest completion if characters cannot be added. @@ -163,22 +164,8 @@ A non-nil value is useful if `pcomplete-autolist' is non-nil too." :type 'boolean :group 'pcomplete) -(defcustom pcomplete-arg-quote-list nil - "List of characters to quote when completing an argument." - :type '(choice (repeat character) - (const :tag "Don't quote" nil)) - :group 'pcomplete) - -(defcustom pcomplete-quote-arg-hook nil - "A hook which is run to quote a character within a filename. -Each function is passed both the filename to be quoted, and the index -to be considered. If the function wishes to provide an alternate -quoted form, it need only return the replacement string. If no -function provides a replacement, quoting shall proceed as normal, -using a backslash to quote any character which is a member of -`pcomplete-arg-quote-list'." - :type 'hook - :group 'pcomplete) +(define-obsolete-variable-alias + 'pcomplete-arg-quote-list 'comint-file-name-quote-list "24.3") (defcustom pcomplete-man-function 'man "A function to that will be called to display a manual page. @@ -368,91 +355,28 @@ modified to be an empty string, or the desired separation string." ;; it pretty much impossible to have completion other than ;; prefix-completion. ;; -;; pcomplete--common-quoted-suffix and pcomplete--table-subvert try to -;; work around this difficulty with heuristics, but it's -;; really a hack. +;; pcomplete--common-suffix and completion-table-subvert try to work around +;; this difficulty with heuristics, but it's really a hack. -(defvar pcomplete-unquote-argument-function nil) +(defvar pcomplete-unquote-argument-function #'comint--unquote-argument) -(defun pcomplete-unquote-argument (s) - (cond - (pcomplete-unquote-argument-function - (funcall pcomplete-unquote-argument-function s)) - ((null pcomplete-arg-quote-list) s) - (t - (replace-regexp-in-string "\\\\\\(.\\)" "\\1" s t)))) +(defsubst pcomplete-unquote-argument (s) + (funcall pcomplete-unquote-argument-function s)) + +(defvar pcomplete-requote-argument-function #'comint--requote-argument) (defun pcomplete--common-suffix (s1 s2) - (assert (not (or (string-match "\n" s1) (string-match "\n" s2)))) ;; Since S2 is expected to be the "unquoted/expanded" version of S1, ;; there shouldn't be any case difference, even if the completion is ;; case-insensitive. - (let ((case-fold-search nil)) ;; pcomplete-ignore-case - (string-match ".*?\\(.*\\)\n.*\\1\\'" (concat s1 "\n" s2)) + (let ((case-fold-search nil)) + (string-match + ;; \x3FFF7F is just an arbitrary char among the ones Emacs accepts + ;; that hopefully will never appear in normal text. + "\\(?:.\\|\n\\)*?\\(\\(?:.\\|\n\\)*\\)\x3FFF7F\\(?:.\\|\n\\)*\\1\\'" + (concat s1 "\x3FFF7F" s2)) (- (match-end 1) (match-beginning 1)))) -(defun pcomplete--common-quoted-suffix (s1 s2) - "Find the common suffix between S1 and S2 where S1 is the expanded S2. -S1 is expected to be the unquoted and expanded version of S1. -Returns (PS1 . PS2), i.e. the shortest prefixes of S1 and S2, such that -S1 = (concat PS1 SS1) and S2 = (concat PS2 SS2) and -SS1 = (unquote SS2)." - (let* ((cs (pcomplete--common-suffix s1 s2)) - (ss1 (substring s1 (- (length s1) cs))) - (qss1 (pcomplete-quote-argument ss1)) - qc) - (if (and (not (equal ss1 qss1)) - (setq qc (pcomplete-quote-argument (substring ss1 0 1))) - (eq t (compare-strings s2 (- (length s2) cs (length qc) -1) - (- (length s2) cs -1) - qc nil nil))) - ;; The difference found is just that one char is quoted in S2 - ;; but not in S1, keep looking before this difference. - (pcomplete--common-quoted-suffix - (substring s1 0 (- (length s1) cs)) - (substring s2 0 (- (length s2) cs (length qc) -1))) - (cons (substring s1 0 (- (length s1) cs)) - (substring s2 0 (- (length s2) cs)))))) - -(defun pcomplete--table-subvert (table s1 s2 string pred action) - "Completion table that replaces the prefix S1 with S2 in STRING. -When TABLE, S1 and S2 are provided by `apply-partially', the result -is a completion table which completes strings of the form (concat S1 S) -in the same way as TABLE completes strings of the form (concat S2 S)." - (let* ((str (if (eq t (compare-strings string 0 (length s1) s1 nil nil - completion-ignore-case)) - (concat s2 (pcomplete-unquote-argument - (substring string (length s1)))))) - (res (if str (complete-with-action action table str pred)))) - (when res - (cond - ((and (eq (car-safe action) 'boundaries)) - (let ((beg (or (and (eq (car-safe res) 'boundaries) (cadr res)) 0))) - (list* 'boundaries - (max (length s1) - ;; FIXME: Adjust because of quoting/unquoting. - (+ beg (- (length s1) (length s2)))) - (and (eq (car-safe res) 'boundaries) (cddr res))))) - ((stringp res) - (if (eq t (compare-strings res 0 (length s2) s2 nil nil - completion-ignore-case)) - (concat s1 (pcomplete-quote-argument - (substring res (length s2)))))) - ((eq action t) - (let ((bounds (completion-boundaries str table pred ""))) - (if (>= (car bounds) (length s2)) - res - (let ((re (concat "\\`" - (regexp-quote (substring s2 (car bounds)))))) - (delq nil - (mapcar (lambda (c) - (if (string-match re c) - (substring c (match-end 0)))) - res)))))))))) - -;; I don't think such commands are usable before first setting up buffer-local -;; variables to parse args, so there's no point autoloading it. -;; ;;;###autoload (defun pcomplete-completions-at-point () "Provide standard completion using pcomplete's completion tables. Same as `pcomplete' but using the standard completion UI." @@ -483,59 +407,56 @@ Same as `pcomplete' but using the standard completion UI." ;; pcomplete-stub and works from the buffer's text instead, ;; we need to trick minibuffer-complete, into using ;; pcomplete-stub without its knowledge. To that end, we - ;; use pcomplete--table-subvert to construct a completion + ;; use completion-table-subvert to construct a completion ;; table which expects strings using a prefix from the ;; buffer's text but internally uses the corresponding ;; prefix from pcomplete-stub. (beg (max (- (point) (length pcomplete-stub)) (pcomplete-begin))) - (buftext (buffer-substring beg (point)))) + (buftext (pcomplete-unquote-argument + (buffer-substring beg (point))))) (when completions (let ((table - (cond - ((not (equal pcomplete-stub buftext)) - ;; This isn't always strictly right (e.g. if - ;; FOO="toto/$FOO", then completion of /$FOO/bar may - ;; result in something incorrect), but given the lack of - ;; any other info, it's about as good as it gets, and in - ;; practice it should work just fine (fingers crossed). - (let ((prefixes (pcomplete--common-quoted-suffix - pcomplete-stub buftext))) - (apply-partially - 'pcomplete--table-subvert + (completion-table-with-quoting + (if (equal pcomplete-stub buftext) completions - (cdr prefixes) (car prefixes)))) - (t - (lexical-let ((completions completions)) - (lambda (string pred action) - (let ((res (complete-with-action - action completions string pred))) - (if (stringp res) - (pcomplete-quote-argument res) - res))))))) + ;; This may not always be strictly right, but given the lack + ;; of any other info, it's about as good as it gets, and in + ;; practice it should work just fine (fingers crossed). + (let ((suf-len (pcomplete--common-suffix + pcomplete-stub buftext))) + (completion-table-subvert + completions + (substring buftext 0 (- (length buftext) suf-len)) + (substring pcomplete-stub 0 + (- (length pcomplete-stub) suf-len))))) + pcomplete-unquote-argument-function + pcomplete-requote-argument-function)) (pred ;; Pare it down, if applicable. (when (and pcomplete-use-paring pcomplete-seen) - (setq pcomplete-seen - (mapcar (lambda (f) - (funcall pcomplete-norm-func - (directory-file-name f))) - pcomplete-seen)) - (lambda (f) - (not (when pcomplete-seen - (member - (funcall pcomplete-norm-func - (directory-file-name f)) - pcomplete-seen))))))) + ;; Capture the dynbound values for later use. + (let ((norm-func pcomplete-norm-func) + (seen + (mapcar (lambda (f) + (funcall pcomplete-norm-func + (directory-file-name f))) + pcomplete-seen))) + (lambda (f) + (not (member + (funcall norm-func (directory-file-name f)) + seen))))))) (when pcomplete-ignore-case - (setq table - (apply-partially #'completion-table-case-fold table))) + (setq table (completion-table-case-fold table))) (list beg (point) table :predicate pred :exit-function + ;; If completion is finished, add a terminating space. + ;; We used to also do this if STATUS is `sole', but + ;; that does not work right when completion cycling. (unless (zerop (length pcomplete-termination-string)) - (lambda (_s finished) - (when (memq finished '(sole finished)) + (lambda (_s status) + (when (eq status 'finished) (if (looking-at (regexp-quote pcomplete-termination-string)) (goto-char (match-end 0)) @@ -780,6 +701,8 @@ dynamic-complete-functions are kept. For comint mode itself, this is `comint-dynamic-complete-functions'." (set (make-local-variable 'pcomplete-parse-arguments-function) 'pcomplete-parse-comint-arguments) + (add-hook 'completion-at-point-functions + 'pcomplete-completions-at-point nil 'local) (set (make-local-variable completef-sym) (copy-sequence (symbol-value completef-sym))) (let* ((funs (symbol-value completef-sym)) @@ -801,6 +724,7 @@ this is `comint-dynamic-complete-functions'." (defun pcomplete-parse-comint-arguments () "Parse whitespace separated arguments in the current region." + (declare (obsolete comint-parse-pcomplete-arguments "24.1")) (let ((begin (save-excursion (comint-bol nil) (point))) (end (point)) begins args) @@ -809,12 +733,14 @@ this is `comint-dynamic-complete-functions'." (while (< (point) end) (skip-chars-forward " \t\n") (push (point) begins) - (let ((skip t)) - (while skip - (skip-chars-forward "^ \t\n") - (if (eq (char-before) ?\\) - (skip-chars-forward " \t\n") - (setq skip nil)))) + (while + (progn + (skip-chars-forward "^ \t\n\\") + (when (eq (char-after) ?\\) + (forward-char 1) + (unless (eolp) + (forward-char 1) + t)))) (push (buffer-substring-no-properties (car begins) (point)) args)) (cons (nreverse args) (nreverse begins))))) @@ -866,36 +792,54 @@ this is `comint-dynamic-complete-functions'." (throw 'pcompleted t) pcomplete-args)))))) -(defun pcomplete-quote-argument (filename) - "Return FILENAME with magic characters quoted. -Magic characters are those in `pcomplete-arg-quote-list'." - (if (null pcomplete-arg-quote-list) - filename - (let ((index 0)) - (mapconcat (lambda (c) - (prog1 - (or (run-hook-with-args-until-success - 'pcomplete-quote-arg-hook filename index) - (when (memq c pcomplete-arg-quote-list) - (string "\\" c)) - (char-to-string c)) - (setq index (1+ index)))) - filename - "")))) +(define-obsolete-function-alias + 'pcomplete-quote-argument #'comint-quote-filename "24.3") ;; file-system completion lists (defsubst pcomplete-dirs-or-entries (&optional regexp predicate) "Return either directories, or qualified entries." - ;; FIXME: pcomplete-entries doesn't return a list any more. (pcomplete-entries nil - (lexical-let ((re regexp) - (pred predicate)) - (lambda (f) - (or (file-directory-p f) - (and (if (not re) t (string-match re f)) - (if (not pred) t (funcall pred f)))))))) + (lambda (f) + (or (file-directory-p f) + (and (or (null regexp) (string-match regexp f)) + (or (null predicate) (funcall predicate f))))))) + +(defun pcomplete--entries (&optional regexp predicate) + "Like `pcomplete-entries' but without env-var handling." + (let* ((ign-pred + (when (or pcomplete-file-ignore pcomplete-dir-ignore) + ;; Capture the dynbound value for later use. + (let ((file-ignore pcomplete-file-ignore) + (dir-ignore pcomplete-dir-ignore)) + (lambda (file) + (not + (if (eq (aref file (1- (length file))) ?/) + (and dir-ignore (string-match dir-ignore file)) + (and file-ignore (string-match file-ignore file)))))))) + (reg-pred (if regexp (lambda (file) (string-match regexp file)))) + (pred (cond + ((null (or ign-pred reg-pred)) predicate) + ((null (or ign-pred predicate)) reg-pred) + ((null (or reg-pred predicate)) ign-pred) + (t (lambda (f) + (and (or (null reg-pred) (funcall reg-pred f)) + (or (null ign-pred) (funcall ign-pred f)) + (or (null predicate) (funcall predicate f)))))))) + (lambda (s p a) + (if (and (eq a 'metadata) pcomplete-compare-entry-function) + `(metadata (cycle-sort-function + . ,(lambda (comps) + (sort comps pcomplete-compare-entry-function))) + ,@(cdr (completion-file-name-table s p a))) + (let ((completion-ignored-extensions nil) + (completion-ignore-case pcomplete-ignore-case)) + (completion-table-with-predicate + #'comint-completion-file-name-table pred 'strict s p a)))))) + +(defconst pcomplete--env-regexp + "\\(?:\\`\\|[^\\]\\)\\(?:\\\\\\\\\\)*\\(\\$\\(?:{\\([^}]+\\)}\\|\\(?2:[[:alnum:]_]+\\)\\)\\)") (defun pcomplete-entries (&optional regexp predicate) "Complete against a list of directory candidates. @@ -905,65 +849,48 @@ If PREDICATE is non-nil, it will also be used to refine the match \(files for which the PREDICATE returns nil will be excluded). If no directory information can be extracted from the completed component, `default-directory' is used as the basis for completion." - (let* ((name (substitute-env-vars pcomplete-stub)) - (completion-ignore-case pcomplete-ignore-case) - (default-directory (expand-file-name - (or (file-name-directory name) - default-directory))) - above-cutoff) - (setq name (file-name-nondirectory name) - pcomplete-stub name) - (let ((completions - (file-name-all-completions name default-directory))) - (if regexp - (setq completions - (pcomplete-pare-list - completions nil - (function - (lambda (file) - (not (string-match regexp file))))))) - (if predicate - (setq completions - (pcomplete-pare-list - completions nil - (function - (lambda (file) - (not (funcall predicate file))))))) - (if (or pcomplete-file-ignore pcomplete-dir-ignore) - (setq completions - (pcomplete-pare-list - completions nil - (function - (lambda (file) - (if (eq (aref file (1- (length file))) - ?/) - (and pcomplete-dir-ignore - (string-match pcomplete-dir-ignore file)) - (and pcomplete-file-ignore - (string-match pcomplete-file-ignore file)))))))) - (setq above-cutoff (and pcomplete-cycle-cutoff-length - (> (length completions) - pcomplete-cycle-cutoff-length))) - (sort completions - (function - (lambda (l r) - ;; for the purposes of comparison, remove the - ;; trailing slash from directory names. - ;; Otherwise, "foo.old/" will come before "foo/", - ;; since . is earlier in the ASCII alphabet than - ;; / - (let ((left (if (eq (aref l (1- (length l))) - ?/) - (substring l 0 (1- (length l))) - l)) - (right (if (eq (aref r (1- (length r))) - ?/) - (substring r 0 (1- (length r))) - r))) - (if above-cutoff - (string-lessp left right) - (funcall pcomplete-compare-entry-function - left right))))))))) + ;; FIXME: The old code did env-var expansion here, so we reproduce this + ;; behavior for now, but really env-var handling should be performed globally + ;; rather than here since it also applies to non-file arguments. + (let ((table (pcomplete--entries regexp predicate))) + (lambda (string pred action) + (let ((strings nil) + (orig-length (length string))) + ;; Perform env-var expansion. + (while (string-match pcomplete--env-regexp string) + (push (substring string 0 (match-beginning 1)) strings) + (push (getenv (match-string 2 string)) strings) + (setq string (substring string (match-end 1)))) + (if (not (and strings + (or (eq action t) + (eq (car-safe action) 'boundaries)))) + (let ((newstring + (mapconcat 'identity (nreverse (cons string strings)) ""))) + ;; FIXME: We could also try to return unexpanded envvars. + (complete-with-action action table newstring pred)) + (let* ((envpos (apply #'+ (mapcar #' length strings))) + (newstring + (mapconcat 'identity (nreverse (cons string strings)) "")) + (bounds (completion-boundaries newstring table pred + (or (cdr-safe action) "")))) + (if (>= (car bounds) envpos) + ;; The env-var is "out of bounds". + (if (eq action t) + (complete-with-action action table newstring pred) + `(boundaries + ,(+ (car bounds) (- orig-length (length newstring))) + . ,(cdr bounds))) + ;; The env-var is in the file bounds. + (if (eq action t) + (let ((comps (complete-with-action + action table newstring pred)) + (len (- envpos (car bounds)))) + ;; Strip the part of each completion that's actually + ;; coming from the env-var. + (mapcar (lambda (s) (substring s len)) comps)) + `(boundaries + ,(+ envpos (- orig-length (length newstring))) + . ,(cdr bounds)))))))))) (defsubst pcomplete-all-entries (&optional regexp predicate) "Like `pcomplete-entries', but doesn't ignore any entries." @@ -1163,7 +1090,7 @@ Typing SPC flushes the help buffer." (setq pcomplete-last-window-config (current-window-configuration))) (with-output-to-temp-buffer "*Completions*" (display-completion-list completions)) - (message "Hit space to flush") + (minibuffer-message "Hit space to flush") (let (event) (prog1 (catch 'done @@ -1203,14 +1130,14 @@ Returns non-nil if a space was appended at the end." (if (not pcomplete-ignore-case) (insert-and-inherit (if raw-p (substring entry (length stub)) - (pcomplete-quote-argument + (comint-quote-filename (substring entry (length stub))))) ;; the stub is not quoted at this time, so to determine the ;; length of what should be in the buffer, we must quote it ;; FIXME: Here we presume that quoting `stub' gives us the exact ;; text in the buffer before point, which is not guaranteed; ;; e.g. it is not the case in eshell when completing ${FOO}tm[TAB]. - (delete-char (- (length (pcomplete-quote-argument stub)))) + (delete-char (- (length (comint-quote-filename stub)))) ;; if there is already a backslash present to handle the first ;; character, don't bother quoting it (when (eq (char-before) ?\\) @@ -1218,7 +1145,7 @@ Returns non-nil if a space was appended at the end." (setq entry (substring entry 1))) (insert-and-inherit (if raw-p entry - (pcomplete-quote-argument entry)))) + (comint-quote-filename entry)))) (let (space-added) (when (and (not (memq (char-before) pcomplete-suffix-list)) addsuffix) @@ -1228,7 +1155,7 @@ Returns non-nil if a space was appended at the end." pcomplete-last-completion-stub stub) space-added))) -;; selection of completions +;; Selection of completions. (defun pcomplete-do-complete (stub completions) "Dynamically complete at point using STUB and COMPLETIONS. @@ -1343,25 +1270,6 @@ If specific documentation can't be given, be generic." ;; general utilities -(defun pcomplete-pare-list (l r &optional pred) - "Destructively remove from list L all elements matching any in list R. -Test is done using `equal'. -If PRED is non-nil, it is a function used for further removal. -Returns the resultant list." - (while (and l (or (and r (member (car l) r)) - (and pred - (funcall pred (car l))))) - (setq l (cdr l))) - (let ((m l)) - (while m - (while (and (cdr m) - (or (and r (member (cadr m) r)) - (and pred - (funcall pred (cadr m))))) - (setcdr m (cddr m))) - (setq m (cdr m)))) - l) - (defun pcomplete-uniqify-list (l) "Sort and remove multiples in L." (setq l (sort l 'string-lessp))