1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-01-30 04:10:54 -08:00

Use completion-in-buffer.

(widget-field-text-end): New function.
(widget-field-value-get): Use it.
(widget-string-complete, widget-file-complete)
(widget-color-complete): Use it and completion-in-region.
(widget-complete): Don't narrow the buffer.
This commit is contained in:
Stefan Monnier 2009-12-02 04:11:08 +00:00
parent 96bdcdc44e
commit bb12edf129
3 changed files with 39 additions and 79 deletions

View file

@ -1,3 +1,12 @@
2009-12-02 Stefan Monnier <monnier@iro.umontreal.ca>
Use completion-in-buffer.
* wid-edit.el (widget-field-text-end): New function.
(widget-field-value-get): Use it.
(widget-string-complete, widget-file-complete)
(widget-color-complete): Use it and completion-in-region.
(widget-complete): Don't narrow the buffer.
2009-12-02 Glenn Morris <rgm@gnu.org>
* mail/rmail.el (rmail-pop-to-buffer): New function. (Bug#2282)

View file

@ -1273,7 +1273,7 @@
* emacs-lisp/debug.el (debug): Fix call to message.
2003-06-16 Michael Mauger <mmaug@yahoo.com> (tiny change)
2003-06-16 Michael Mauger <mmaug@yahoo.com>
* emulation/cua-base.el (cua-mode): Use explicit arg to turn off
minor modes.

View file

@ -1160,11 +1160,9 @@ the field."
When not inside a field, move to the previous button or field."
(interactive)
(let ((field (widget-field-find (point))))
(if field
(save-restriction
(widget-narrow-to-field)
(widget-apply field :complete))
(error "Not in an editable field"))))
(when field
(widget-apply field :complete))
(error "Not in an editable field")))
;;; Setting up the buffer.
@ -1257,6 +1255,19 @@ When not inside a field, move to the previous button or field."
(overlay-end overlay)))
(cdr overlay))))
(defun widget-field-text-end (widget)
(let ((to (widget-field-end widget))
(size (widget-get widget :size)))
(if (or (null size) (zerop size))
to
(let ((from (widget-field-start widget)))
(if (and from to)
(with-current-buffer (widget-field-buffer widget)
(while (and (> to from)
(eq (char-after (1- to)) ?\s))
(setq to (1- to)))
to))))))
(defun widget-field-find (pos)
"Return the field at POS.
Unlike (get-char-property POS 'field), this works with empty fields too."
@ -1935,7 +1946,7 @@ the earlier input."
(defun widget-field-value-get (widget)
"Return current text in editing field."
(let ((from (widget-field-start widget))
(to (widget-field-end widget))
(to (widget-field-text-end widget))
(buffer (widget-field-buffer widget))
(size (widget-get widget :size))
(secret (widget-get widget :secret))
@ -1943,11 +1954,6 @@ the earlier input."
(if (and from to)
(progn
(set-buffer buffer)
(while (and size
(not (zerop size))
(> to from)
(eq (char-after (1- to)) ?\s))
(setq to (1- to)))
(let ((result (buffer-substring-no-properties from to)))
(when secret
(let ((index 0))
@ -3029,35 +3035,13 @@ as the value."
Completions are taken from the :completion-alist property of the
widget. If that isn't a list, it's evalled and expected to yield a list."
(interactive)
(let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
(point)))
(completion-ignore-case (widget-get widget :completion-ignore-case))
(let* ((completion-ignore-case (widget-get widget :completion-ignore-case))
(alist (widget-get widget :completion-alist))
(_ (unless (listp alist)
(setq alist (eval alist))))
(completion (try-completion prefix alist)))
(cond ((eq completion t)
(when completion-ignore-case
;; Replace field with completion in case its case is different.
(delete-region (widget-field-start widget)
(widget-field-end widget))
(insert-and-inherit (car (assoc-string prefix alist t))))
(message "Only match"))
((null completion)
(error "No match"))
((not (eq t (compare-strings prefix nil nil completion nil nil
completion-ignore-case)))
(when completion-ignore-case
;; Replace field with completion in case its case is different.
(delete-region (widget-field-start widget)
(widget-field-end widget))
(insert-and-inherit completion)))
(t
(message "Making completion list...")
(with-output-to-temp-buffer "*Completions*"
(display-completion-list
(all-completions prefix alist nil)))
(message "Making completion list...done")))))
(setq alist (eval alist)))))
(completion-in-region (widget-field-start widget)
(max (point) (widget-field-text-end widget))
alist)))
(define-widget 'regexp 'string
"A regular expression."
@ -3096,29 +3080,9 @@ It reads a file name from an editable text field."
(defun widget-file-complete ()
"Perform completion on file name preceding point."
(interactive)
(let* ((end (point))
(beg (widget-field-start widget))
(pattern (buffer-substring beg end))
(name-part (file-name-nondirectory pattern))
;; I think defaulting to root is right
;; because these really should be absolute file names.
(directory (or (file-name-directory pattern) "/"))
(completion (file-name-completion name-part directory)))
(cond ((eq completion t))
((null completion)
(message "Can't find completion for \"%s\"" pattern)
(ding))
((not (string= name-part completion))
(delete-region beg end)
(insert (expand-file-name completion directory)))
(t
(message "Making completion list...")
(with-output-to-temp-buffer "*Completions*"
(display-completion-list
(sort (file-name-all-completions name-part directory)
'string<)
name-part))
(message "Making completion list...%s" "done")))))
(completion-in-region (widget-field-start widget)
(max (point) (widget-field-text-end widget))
'completion-file-name-table))
(defun widget-file-prompt-value (widget prompt value unbound)
;; Read file from minibuffer.
@ -3738,23 +3702,10 @@ example:
(defun widget-color-complete (widget)
"Complete the color in WIDGET."
(require 'facemenu) ; for facemenu-color-alist
(let* ((prefix (buffer-substring-no-properties (widget-field-start widget)
(point)))
(list (or facemenu-color-alist
(sort (defined-colors) 'string-lessp)))
(completion (try-completion prefix list)))
(cond ((eq completion t)
(message "Exact match."))
((null completion)
(error "Can't find completion for \"%s\"" prefix))
((not (string-equal prefix completion))
(insert-and-inherit (substring completion (length prefix))))
(t
(message "Making completion list...")
(with-output-to-temp-buffer "*Completions*"
(display-completion-list (all-completions prefix list nil)
prefix))
(message "Making completion list...done")))))
(completion-in-region (widget-field-start widget)
(max (point) (widget-field-text-end widget))
(or facemenu-color-alist
(sort (defined-colors) 'string-lessp))))
(defun widget-color-sample-face-get (widget)
(let* ((value (condition-case nil