;;; 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, 2009 Free Software Foundation, Inc.
+;; 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; Keywords: extensions
+;; Package: emacs
;; This file is part of GNU Emacs.
: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."
;; 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)
(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)))
+ (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))
(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.")
(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))))
- (when field
- (widget-apply field :complete))
- (error "Not in an editable field")))
+ (if field
+ (widget-apply field :complete)
+ (error "Not in an editable field"))))
;;; Setting up the buffer.
(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))))
;; 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))
(let ((from (widget-field-start 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)
;; 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 "%\\([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)
;;; 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-image 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-image 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-image "down"
:on "Hide"
+ :off-image "right"
:off "Show"
:value-create 'widget-visibility-value-create
:action 'widget-toggle-action
(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"))))
+ (let* ((val (widget-value widget))
+ (text (widget-get widget (if val :on :off)))
+ (img (widget-image-find
+ (widget-get widget (if val :on-image :off-image)))))
+ (widget-image-insert widget
+ (if text
+ (concat widget-push-button-prefix text
+ widget-push-button-suffix)
+ "")
+ (if img
+ (append img '(:ascent center))))))
;;; 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
(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