;;; 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, 2008 Free Software Foundation, Inc.
+;; Copyright (C) 1996-1997, 1999-2011 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
;;; Code:
-(defvar widget)
-
;;; Compatibility.
(defun widget-event-point (event)
:link '(custom-manual "(widget)Top")
:link '(emacs-library-link :tag "Lisp File" "widget.el")
:prefix "widget-"
- :group 'extensions
- :group 'hypermedia)
+ :group 'extensions)
(defgroup widget-documentation nil
"Options controlling the display of documentation strings."
"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
;; Allocate digits to disabled alternatives
;; so that the digit of a given alternative never varies.
(setq next-digit (1+ next-digit)))
- (insert "\nC-g = Quit"))
+ (insert "\nC-g = Quit")
+ (goto-char (point-min))
+ (forward-line))
(or some-choice-enabled
(error "None of the choices is currently meaningful"))
(define-key map [?\C-g] 'keyboard-quit)
(defvar widget-field-use-before-change t
"Non-nil means use `before-change-functions' to track editable fields.
-This enables the use of undo, but doesn't work on Emacs 19.34 and earlier.
-Using before hooks also means that the :notify function can't know the
-new value.")
+This enables the use of undo. Using before hooks also means that
+the :notify function can't know the new value.")
(defun widget-specify-field (widget from to)
"Specify editable button for WIDGET between FROM and TO."
'((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."
specs)
(dolist (elt widget-image-conversion)
(dolist (ext (cdr elt))
- (push (list :type (car elt) :file (concat image ext)) specs)))
- (setq specs (nreverse specs))
- (find-image specs)))
+ (push (list :type (car elt) :file (concat image ext))
+ specs)))
+ (find-image (nreverse specs))))
(t
;; Oh well.
nil)))
Optional arguments DOWN and INACTIVE are used instead of IMAGE when the
button is pressed or inactive, respectively. These are currently ignored."
- (if (and (display-graphic-p)
+ (if (and (featurep 'image)
(setq image (widget-image-find image)))
(progn (widget-put widget :suppress-face t)
(insert-image image tag))
;; 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
-(defalias 'advertised-widget-backward 'widget-backward)
+(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 [(control ?m)] 'widget-button-press)
map)
"Keymap containing useful binding for buffers containing widgets.
-Recommended as a parent keymap for modes using widgets.")
+Recommended as a parent keymap for modes using widgets.
+Note that such modes will need to require wid-edit.")
(defvar widget-global-map global-map
"Keymap used for events a widget does not handle itself.")
(: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.
(defvar widget-use-overlay-change t
"If non-nil, use overlay change functions to tab around in the buffer.
-This is much faster, but doesn't work reliably on Emacs 19.34.")
+This is much faster.")
(defun widget-move (arg)
"Move point to the ARG next field or button.
(if field
(narrow-to-region (line-beginning-position) (line-end-position)))))
+;; This used to say:
+;; "When not inside a field, move to the previous button or field."
+;; but AFAICS, it has always just thrown an error.
(defun widget-complete ()
"Complete content of editable field from point.
-When not inside a field, move to the previous button or field."
+When not inside a field, signal an error."
(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"))))
+ (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."
(goto-char end)
(while (and (eq (preceding-char) ?\s)
(> (point) begin))
- (delete-backward-char 1)))))))
+ (delete-char -1)))))))
(widget-specify-secret field))
(widget-apply field :notify field))))
:notify 'widget-default-notify
:prompt-value 'widget-default-prompt-value)
+(defvar widget--completing-widget)
+
(defun widget-default-complete (widget)
"Call the value of the :complete-function property of WIDGET.
-If that does not exist, call the value of `widget-complete-field'."
- (call-interactively (or (widget-get widget :complete-function)
- widget-complete-field)))
+If that does not exist, call the value of `widget-complete-field'.
+During this call, `widget--completing-widget' is bound to WIDGET."
+ (let ((widget--completing-widget widget))
+ (call-interactively (or (widget-get widget :complete-function)
+ widget-complete-field))))
(defun widget-default-create (widget)
"Create WIDGET at point in the current buffer."
;; Parse escapes in format.
(while (re-search-forward "%\\(.\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?\[)
(setq doc-begin (point))
(insert doc)
(while (eq (preceding-char) ?\n)
- (delete-backward-char 1))
+ (delete-char -1))
(insert ?\n)
(setq doc-end (point)))))
((eq escape ?h)
:valid-regexp ""
:error "Field's value doesn't match allowed forms"
:value-create 'widget-field-value-create
+ :value-set 'widget-field-value-set
:value-delete 'widget-field-value-delete
:value-get 'widget-field-value-get
:match 'widget-field-match)
(widget-apply widget :value-get))
widget))
+(defun widget-field-value-set (widget value)
+ "Set an editable text field WIDGET to VALUE"
+ (let ((from (widget-field-start widget))
+ (to (widget-field-text-end widget))
+ (buffer (widget-field-buffer widget))
+ (size (widget-get widget :size)))
+ (when (and from to (buffer-live-p buffer))
+ (with-current-buffer buffer
+ (goto-char from)
+ (delete-char (- to from))
+ (insert value)))))
+
(defun widget-field-value-create (widget)
"Create an editable text field."
(let ((size (widget-get widget :size))
(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))
(old (current-buffer)))
(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))
(defun widget-toggle-value-create (widget)
"Insert text representing the `on' and `off' states."
- (if (widget-value widget)
- (let ((image (widget-get widget :on-glyph)))
- (and (display-graphic-p)
- (listp image)
- (not (eq (car image) 'image))
- (widget-put widget :on-glyph (setq image (eval image))))
- (widget-image-insert widget
- (widget-get widget :on)
- image))
- (let ((image (widget-get widget :off-glyph)))
- (and (display-graphic-p)
- (listp image)
- (not (eq (car image) 'image))
- (widget-put widget :off-glyph (setq image (eval image))))
- (widget-image-insert widget (widget-get widget :off) image))))
+ (let* ((val (widget-value widget))
+ (text (widget-get widget (if val :on :off)))
+ (img (widget-image-find
+ (widget-get widget (if val :on-glyph :off-glyph)))))
+ (widget-image-insert widget (or text "")
+ (if img
+ (append img '(:ascent center))))))
(defun widget-toggle-action (widget &optional event)
;; Toggle value.
;; We could probably do the same job as the images using single
;; space characters in a boxed face with a stretch specification to
;; make them square.
- :on-glyph '(create-image "\300\300\141\143\067\076\034\030"
- 'xbm t :width 8 :height 8
- :background "grey75" ; like default mode line
- :foreground "black"
- :relief -2
- :ascent 'center)
+ :on-glyph "checked"
:off "[ ]"
- :off-glyph '(create-image (make-string 8 0)
- 'xbm t :width 8 :height 8
- :background "grey75"
- :foreground "black"
- :relief -2
- :ascent 'center)
+ :off-glyph "unchecked"
:help-echo "Toggle this item."
:action 'widget-checkbox-action)
(defun widget-checklist-value-create (widget)
;; Insert all values
- (let ((alist (widget-checklist-match-find widget (widget-get widget :value)))
- (args (widget-get widget :args)))
- (while args
- (widget-checklist-add-item widget (car args) (assq (car args) alist))
- (setq args (cdr args)))
+ (let ((alist (widget-checklist-match-find widget))
+ (args (widget-get widget :args)))
+ (dolist (item args)
+ (widget-checklist-add-item widget item (assq item alist)))
(widget-put widget :children (nreverse (widget-get widget :children)))))
(defun widget-checklist-add-item (widget type chosen)
;; Parse % escapes in format.
(while (re-search-forward "%\\([bv%]\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?b)
values nil)))))
(cons found rest)))
-(defun widget-checklist-match-find (widget vals)
+(defun widget-checklist-match-find (widget &optional vals)
"Find the vals which match a type in the checklist.
Return an alist of (TYPE MATCH)."
+ (or vals (setq vals (widget-get widget :value)))
(let ((greedy (widget-get widget :greedy))
(args (copy-sequence (widget-get widget :args)))
found)
;; Parse % escapes in format.
(while (re-search-forward "%\\([bv%]\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?b)
;; Parse % escapes in format.
(while (re-search-forward "%\\(.\\)" nil t)
(let ((escape (char-after (match-beginning 1))))
- (delete-backward-char 2)
+ (delete-char -2)
(cond ((eq escape ?%)
(insert ?%))
((eq escape ?i)
argument answer found)
(while args
(setq argument (car args)
- args (cdr args)
- answer (widget-match-inline argument vals))
- (if answer
- (setq vals (cdr answer)
- found (append found (car answer)))
+ args (cdr args))
+ (if (setq answer (widget-match-inline argument vals))
+ (setq found (append found (car answer))
+ vals (cdr answer))
(setq vals nil
args nil)))
(if answer
;;; The `visibility' Widget.
(define-widget 'visibility 'item
- "An indicator and manipulator for hidden items."
+ "An indicator and manipulator for hidden items.
+
+The following properties have special meanings for this widget:
+:on-glyph Image filename or spec to display when the item is visible.
+:on Text shown if the \"on\" image is nil or cannot be displayed.
+:off-glyph Image filename or spec to display when the item is hidden.
+:off Text shown if the \"off\" image is nil cannot be displayed."
:format "%[%v%]"
:button-prefix ""
:button-suffix ""
+ :on-glyph "down"
:on "Hide"
+ :off-glyph "right"
:off "Show"
:value-create 'widget-visibility-value-create
:action 'widget-toggle-action
:match (lambda (widget value) t))
-(defun widget-visibility-value-create (widget)
- ;; Insert text representing the `on' and `off' states.
- (let ((on (widget-get widget :on))
- (off (widget-get widget :off)))
- (if on
- (setq on (concat widget-push-button-prefix
- on
- widget-push-button-suffix))
- (setq on ""))
- (if off
- (setq off (concat widget-push-button-prefix
- off
- widget-push-button-suffix))
- (setq off ""))
- (if (widget-value widget)
- (widget-image-insert widget on "down" "down-pushed")
- (widget-image-insert widget off "right" "right-pushed"))))
+(defalias 'widget-visibility-value-create 'widget-toggle-value-create)
;;; The `documentation-link' Widget.
;;
(widget-create-child-and-convert
widget (widget-get widget :visibility-widget)
:help-echo "Show or hide rest of the documentation."
- :on "Hide Rest"
+ :on "Hide"
:off "More"
:always-active t
:action 'widget-parent-action
: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* ((prefix (buffer-substring-no-properties (widget-field-start widget)
- (point)))
+ (let* ((widget widget--completing-widget)
(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."
(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")))))
+ (let ((widget widget--completing-widget))
+ (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.
(define-widget 'color 'editable-field
"Choose a color name (with sample)."
:format "%{%t%}: %v (%{sample%})\n"
+ :value-create 'widget-color-value-create
:size 10
:tag "Color"
:value "black"
:notify 'widget-color-notify
:action 'widget-color-action)
+(defun widget-color-value-create (widget)
+ (widget-field-value-create widget)
+ (widget-insert " ")
+ (widget-create-child-and-convert
+ widget 'push-button
+ :tag " Choose " :action 'widget-color--choose-action)
+ (widget-insert " "))
+
+(defun widget-color--choose-action (widget &optional event)
+ (list-colors-display
+ nil nil
+ `(lambda (color)
+ (when (buffer-live-p ,(current-buffer))
+ (widget-value-set ',(widget-get widget :parent) color)
+ (let* ((buf (get-buffer "*Colors*"))
+ (win (get-buffer-window buf 0)))
+ (bury-buffer buf)
+ (and win (> (length (window-list)) 1)
+ (delete-window win)))
+ (pop-to-buffer ,(current-buffer))))))
+
(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
(provide 'wid-edit)
-;; arch-tag: a076e75e-18a1-4b46-8be5-3f317bcbc707
;;; wid-edit.el ends here
HCoop / bpt / emacs.git / blobdiff