X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/1bb9a689acfe821e0aa777ddf4e074556c7817a1..bb12edf129de7f0c9cb5eca4bbc58f4d04051d8d:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 72cff55805..f96c71995a 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,7 +1,7 @@ ;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*- ;; -;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003, 2004, 2005, +;; 2006, 2007, 2008, 2009 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Maintainer: FSF @@ -9,10 +9,10 @@ ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -20,9 +20,7 @@ ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Wishlist items (from widget.texi): @@ -106,8 +104,8 @@ This exists as a variable so it can be set locally in certain buffers.") "Face used for documentation text." :group 'widget-documentation :group 'widget-faces) -;; backward compatibility alias -(put 'widget-documentation-face 'face-alias 'widget-documentation) +(define-obsolete-face-alias 'widget-documentation-face + 'widget-documentation "22.1") (defvar widget-button-face 'widget-button "Face used for buttons in widgets. @@ -116,8 +114,7 @@ This exists as a variable so it can be set locally in certain buffers.") (defface widget-button '((t (:weight bold))) "Face used for widget buttons." :group 'widget-faces) -;; backward compatibility alias -(put 'widget-button-face 'face-alias 'widget-button) +(define-obsolete-face-alias 'widget-button-face 'widget-button "22.1") (defcustom widget-mouse-face 'highlight "Face used for widget buttons when the mouse is above them." @@ -140,8 +137,7 @@ This exists as a variable so it can be set locally in certain buffers.") :slant italic)) "Face used for editable fields." :group 'widget-faces) -;; backward-compatibility alias -(put 'widget-field-face 'face-alias 'widget-field) +(define-obsolete-face-alias 'widget-field-face 'widget-field "22.1") (defface widget-single-line-field '((((type tty)) :background "green3" @@ -156,8 +152,8 @@ This exists as a variable so it can be set locally in certain buffers.") :slant italic)) "Face used for editable fields spanning only a single line." :group 'widget-faces) -;; backward-compatibility alias -(put 'widget-single-line-field-face 'face-alias 'widget-single-line-field) +(define-obsolete-face-alias 'widget-single-line-field-face + 'widget-single-line-field "22.1") ;;; This causes display-table to be loaded, and not usefully. ;;;(defvar widget-single-line-display-table @@ -200,7 +196,7 @@ For a larger number of items, the minibuffer is used." :type 'integer) (defcustom widget-menu-minibuffer-flag nil - "*Control how to ask for a choice from the keyboard. + "Control how to ask for a choice from the keyboard. Non-nil means use the minibuffer; nil means read a single character." :group 'widgets @@ -405,7 +401,17 @@ new value.") (unless (widget-get widget :suppress-face) (overlay-put overlay 'face (widget-apply widget :button-face-get)) (overlay-put overlay 'mouse-face - (widget-apply widget :mouse-face-get))) + ;; Make new list structure for the mouse-face value + ;; so that different widgets will have + ;; different `mouse-face' property values + ;; and will highlight separately. + (let ((mouse-face-value + (widget-apply widget :mouse-face-get))) + ;; If it's a list, copy it. + (if (listp mouse-face-value) + (copy-sequence mouse-face-value) + ;; If it's a symbol, put it in a list. + (list mouse-face-value))))) (overlay-put overlay 'pointer 'hand) (overlay-put overlay 'follow-link follow-link) (overlay-put overlay 'help-echo help-echo))) @@ -447,8 +453,8 @@ new value.") '((t :inherit shadow)) "Face used for inactive widgets." :group 'widget-faces) -;; backward-compatibility alias -(put 'widget-inactive-face 'face-alias 'widget-inactive) +(define-obsolete-face-alias 'widget-inactive-face + 'widget-inactive "22.1") (defun widget-specify-inactive (widget from to) "Make WIDGET inactive for user modifications." @@ -478,7 +484,7 @@ new value.") ;;; Widget Properties. (defsubst widget-type (widget) - "Return the type of WIDGET, a symbol." + "Return the type of WIDGET. The type is a symbol." (car widget)) ;;;###autoload @@ -591,7 +597,7 @@ respectively." ;;; Images. (defcustom widget-image-directory (file-name-as-directory - (expand-file-name "custom" data-directory)) + (expand-file-name "images/custom" data-directory)) "Where widget button images are located. If this variable is nil, widget will try to locate the directory automatically." @@ -654,9 +660,7 @@ button is pressed or inactive, respectively. These are currently ignored." (if (and (display-graphic-p) (setq image (widget-image-find image))) (progn (widget-put widget :suppress-face t) - (insert-image image - (propertize - tag 'mouse-face widget-button-pressed-face))) + (insert-image image tag)) (insert tag))) (defun widget-move-and-invoke (event) @@ -850,19 +854,25 @@ button end points." ;;; Keymap and Commands. -;;;###autoload -(defalias 'advertised-widget-backward 'widget-backward) +;; This alias exists only so that one can choose in doc-strings (e.g. +;; Custom-mode) which key-binding of widget-keymap one wants to refer to. +;; http://lists.gnu.org/archive/html/emacs-devel/2008-11/msg00480.html +(define-obsolete-function-alias 'advertised-widget-backward + 'widget-backward "23.2") ;;;###autoload (defvar widget-keymap (let ((map (make-sparse-keymap))) (define-key map "\t" 'widget-forward) (define-key map "\e\t" 'widget-backward) - (define-key map [(shift tab)] 'advertised-widget-backward) + (define-key map [(shift tab)] 'widget-backward) + (put 'widget-backward :advertised-binding [(shift tab)]) (define-key map [backtab] 'widget-backward) (define-key map [down-mouse-2] 'widget-button-click) (define-key map [down-mouse-1] 'widget-button-click) - (define-key map "\C-m" 'widget-button-press) + ;; The following definition needs to avoid using escape sequences that + ;; might get converted to ^M when building loaddefs.el + (define-key map [(control ?m)] 'widget-button-press) map) "Keymap containing useful binding for buffers containing widgets. Recommended as a parent keymap for modes using widgets.") @@ -910,8 +920,8 @@ Recommended as a parent keymap for modes using widgets.") (:weight bold :underline t))) "Face used for pressed buttons." :group 'widget-faces) -;; backward-compatibility alias -(put 'widget-button-pressed-face 'face-alias 'widget-button-pressed) +(define-obsolete-face-alias 'widget-button-pressed-face + 'widget-button-pressed "22.1") (defvar widget-button-click-moves-point nil "If non-nil, `widget-button-click' moves point to a button after invoking it. @@ -1150,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. @@ -1247,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." @@ -1438,7 +1459,7 @@ The value of the :type attribute should be an unconverted widget type." (defun widget-default-complete (widget) "Call the value of the :complete-function property of WIDGET. -If that does not exists, call the value of `widget-complete-field'." +If that does not exist, call the value of `widget-complete-field'." (call-interactively (or (widget-get widget :complete-function) widget-complete-field))) @@ -1759,7 +1780,7 @@ If END is omitted, it defaults to the length of LIST." "An embedded link." :button-prefix 'widget-link-prefix :button-suffix 'widget-link-suffix - :follow-link "\C-m" + :follow-link 'mouse-face :help-echo "Follow the link." :format "%[%t%]") @@ -1925,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)) @@ -1933,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)) @@ -3012,42 +3028,20 @@ as the value." :complete-function 'ispell-complete-word :prompt-history 'widget-string-prompt-value-history) -(eval-when-compile (defvar widget)) +(defvar widget) (defun widget-string-complete () "Complete contents of string field. 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-ignore-case prefix alist)))) - (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." @@ -3086,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. @@ -3290,7 +3264,7 @@ It reads a directory name from an editable text field." (setq unread-command-events (cons ev unread-command-events) ev (read-quoted-char (format "Enter code (radix %d)" read-quoted-char-radix)) tr nil) - (if (and (integerp ev) (not (char-valid-p ev))) + (if (and (integerp ev) (not (characterp ev))) (insert (char-to-string ev)))) ;; throw invalid char error (setq ev (key-description (list ev))) (when (arrayp tr) @@ -3728,22 +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 (defined-colors))) - (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 @@ -3785,5 +3747,5 @@ example: (provide 'wid-edit) -;;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707 +;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707 ;;; wid-edit.el ends here