;;; 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 <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; 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
;; 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 <http://www.gnu.org/licenses/>.
;;; Wishlist items (from widget.texi):
"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.
(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."
: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"
: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
: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
(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)))
'((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."
;;; 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
;;; 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."
(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)
;;; 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.")
(: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.
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.
(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."
(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)))
"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%]")
(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))
(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))
:complete-function 'ispell-complete-word
:prompt-history 'widget-string-prompt-value-history)
+(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* ((completion-ignore-case (widget-get widget :completion-ignore-case))
+ (alist (widget-get widget :completion-alist))
+ (_ (unless (listp alist)
+ (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."
:match 'widget-regexp-match
(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.
(interactive)
(lisp-complete-symbol 'boundp))
:tag "Variable")
-\f
-(defvar widget-coding-system-prompt-value-history nil
- "History of input to `widget-coding-system-prompt-value'.")
(define-widget 'coding-system 'symbol
"A MULE coding-system."
:format "%{%t%}: %v"
:tag "Coding system"
:base-only nil
- :prompt-history 'widget-coding-system-prompt-value-history
+ :prompt-history 'coding-system-value-history
:prompt-value 'widget-coding-system-prompt-value
:action 'widget-coding-system-action
:complete-function (lambda ()
(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)
(aref value 0)
value))
:match (lambda (widget value)
- (char-valid-p value)))
+ (characterp value)))
(define-widget 'list 'group
"A Lisp list."
(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
(provide 'wid-edit)
-;;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707
+;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707
;;; wid-edit.el ends here
HCoop / bpt / emacs.git / blobdiff