;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*-
;;
;; Copyright (C) 1996, 1997, 1999, 2000, 2001, 2002, 2003,
-;; 2004, 2005 Free Software Foundation, Inc.
+;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
;; 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 2, or (at your option)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
:group 'hypermedia)
(defgroup widget-documentation nil
- "Options controling the display of documentation strings."
+ "Options controlling the display of documentation strings."
:group 'widgets)
(defgroup widget-faces nil
keys
(char 0)
(arg 1))
- (while (not (or (and (>= char ?0) (< char next-digit))
+ (while (not (or (and (integerp char)
+ (>= char ?0) (< char next-digit))
(eq value 'keyboard-quit)))
;; Unread a SPC to lead to our new menu.
(setq unread-command-events (cons ?\s unread-command-events))
(setq keys (read-key-sequence title))
(setq value
(lookup-key overriding-terminal-local-map keys t)
- char (string-to-char (substring keys 1)))
+ char (aref keys 1))
(cond ((eq value 'scroll-other-window)
(let ((minibuffer-scroll-window
(get-buffer-window buf)))
;; We want to avoid the face with image buttons.
(unless (widget-get widget :suppress-face)
(overlay-put overlay 'face (widget-apply widget :button-face-get))
- (overlay-put overlay 'mouse-face widget-mouse-face))
+ (overlay-put overlay 'mouse-face
+ (widget-apply widget :mouse-face-get)))
(overlay-put overlay 'pointer 'hand)
(overlay-put overlay 'follow-link follow-link)
(overlay-put overlay 'help-echo help-echo)))
;;;###autoload
(defun widgetp (widget)
- "Return non-nil iff WIDGET is a widget."
+ "Return non-nil if WIDGET is a widget."
(if (symbolp widget)
(get widget 'widget-type)
(and (consp widget)
value)))
(defun widget-member (widget property)
- "Non-nil iff there is a definition in WIDGET for PROPERTY."
+ "Non-nil if there is a definition in WIDGET for PROPERTY."
(cond ((plist-member (cdr widget) property)
t)
((car widget)
:type 'directory)
(defcustom widget-image-enable t
- "If non nil, use image buttons in widgets when available."
+ "If non-nil, use image buttons in widgets when available."
:version "21.1"
:group 'widgets
:type 'boolean)
;;; Keymap and Commands.
+;;;###autoload
+(defalias 'advertised-widget-backward 'widget-backward)
+
;;;###autoload
(defvar widget-keymap
(let ((map (make-sparse-keymap)))
(define-key map "\t" 'widget-forward)
- (define-key map [(shift tab)] 'widget-backward)
+ (define-key map "\e\t" 'widget-backward)
+ (define-key map [(shift tab)] 'advertised-widget-backward)
(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)
map)
"Keymap containing useful binding for buffers containing widgets.
;; backward-compatibility alias
(put 'widget-button-pressed-face 'face-alias 'widget-button-pressed)
+(defvar widget-button-click-moves-point nil
+ "If non-nil, `widget-button-click' moves point to a button after invoking it.
+If nil, point returns to its original position after invoking a button.")
+
(defun widget-button-click (event)
"Invoke the button that the mouse is pointing at."
(interactive "e")
(if (widget-event-point event)
- (let* ((pos (widget-event-point event))
+ (let* ((oevent event)
+ (mouse-1 (memq (event-basic-type event) '(mouse-1 down-mouse-1)))
+ (pos (widget-event-point event))
(start (event-start event))
(button (get-char-property
pos 'button (and (windowp (posn-window start))
- (window-buffer (posn-window start))))))
- (if button
- ;; Mouse click on a widget button. Do the following
- ;; in a save-excursion so that the click on the button
- ;; doesn't change point.
- (save-selected-window
- (select-window (posn-window (event-start event)))
- (save-excursion
- (goto-char (posn-point (event-start event)))
- (let* ((overlay (widget-get button :button-overlay))
- (face (overlay-get overlay 'face))
- (mouse-face (overlay-get overlay 'mouse-face)))
- (unwind-protect
- ;; Read events, including mouse-movement events
- ;; until we receive a release event. Highlight/
- ;; unhighlight the button the mouse was initially
- ;; on when we move over it.
- (save-excursion
- (when face ; avoid changing around image
- (overlay-put overlay
- 'face widget-button-pressed-face)
- (overlay-put overlay
- 'mouse-face widget-button-pressed-face))
- (unless (widget-apply button :mouse-down-action event)
- (let ((track-mouse t))
- (while (not (widget-button-release-event-p event))
- (setq event (read-event)
- pos (widget-event-point event))
- (if (and pos
- (eq (get-char-property pos 'button)
- button))
- (when face
- (overlay-put overlay
- 'face
- widget-button-pressed-face)
- (overlay-put overlay
- 'mouse-face
- widget-button-pressed-face))
- (overlay-put overlay 'face face)
- (overlay-put overlay 'mouse-face mouse-face)))))
-
- ;; When mouse is released over the button, run
- ;; its action function.
- (when (and pos
- (eq (get-char-property pos 'button) button))
- (widget-apply-action button event)))
- (overlay-put overlay 'face face)
- (overlay-put overlay 'mouse-face mouse-face))))
-
- (unless (pos-visible-in-window-p (widget-event-point event))
- (mouse-set-point event)
- (beginning-of-line)
- (recenter))
- )
-
+ (window-buffer (posn-window start)))))
+ newpoint)
+ (when (or (null button)
+ (catch 'button-press-cancelled
+ ;; Mouse click on a widget button. Do the following
+ ;; in a save-excursion so that the click on the button
+ ;; doesn't change point.
+ (save-selected-window
+ (select-window (posn-window (event-start event)))
+ (save-excursion
+ (goto-char (posn-point (event-start event)))
+ (let* ((overlay (widget-get button :button-overlay))
+ (pressed-face (or (widget-get button :pressed-face)
+ widget-button-pressed-face))
+ (face (overlay-get overlay 'face))
+ (mouse-face (overlay-get overlay 'mouse-face)))
+ (unwind-protect
+ ;; Read events, including mouse-movement
+ ;; events, waiting for a release event. If we
+ ;; began with a mouse-1 event and receive a
+ ;; movement event, that means the user wants
+ ;; to perform drag-selection, so cancel the
+ ;; button press and do the default mouse-1
+ ;; action. For mouse-2, just highlight/
+ ;; unhighlight the button the mouse was
+ ;; initially on when we move over it.
+ (save-excursion
+ (when face ; avoid changing around image
+ (overlay-put overlay 'face pressed-face)
+ (overlay-put overlay 'mouse-face pressed-face))
+ (unless (widget-apply button :mouse-down-action event)
+ (let ((track-mouse t))
+ (while (not (widget-button-release-event-p event))
+ (setq event (read-event))
+ (when (and mouse-1 (mouse-movement-p event))
+ (push event unread-command-events)
+ (setq event oevent)
+ (throw 'button-press-cancelled t))
+ (unless (or (integerp event)
+ (memq (car event) '(switch-frame select-window))
+ (eq (car event) 'scroll-bar-movement))
+ (setq pos (widget-event-point event))
+ (if (and pos
+ (eq (get-char-property pos 'button)
+ button))
+ (when face
+ (overlay-put overlay 'face pressed-face)
+ (overlay-put overlay 'mouse-face pressed-face))
+ (overlay-put overlay 'face face)
+ (overlay-put overlay 'mouse-face mouse-face))))))
+
+ ;; When mouse is released over the button, run
+ ;; its action function.
+ (when (and pos (eq (get-char-property pos 'button) button))
+ (goto-char pos)
+ (widget-apply-action button event)
+ (if widget-button-click-moves-point
+ (setq newpoint (point)))))
+ (overlay-put overlay 'face face)
+ (overlay-put overlay 'mouse-face mouse-face))))
+
+ (if newpoint (goto-char newpoint))
+ ;; This loses if the widget action switches windows. -- cyd
+ ;; (unless (pos-visible-in-window-p (widget-event-point event))
+ ;; (mouse-set-point event)
+ ;; (beginning-of-line)
+ ;; (recenter))
+ )
+ nil))
(let ((up t) command)
;; Mouse click not on a widget button. Find the global
;; command to run, and check whether it is bound to an
;; up event.
- (mouse-set-point event)
- (if (memq (event-basic-type event) '(mouse-1 down-mouse-1))
+ (if mouse-1
(cond ((setq command ;down event
(lookup-key widget-global-map [down-mouse-1]))
(setq up nil))
;; or if a special `boundary' field has been added after the widget
;; field.
(if (overlayp overlay)
- (if (and (not (eq (with-current-buffer
- (widget-field-buffer widget)
- (save-restriction
- ;; `widget-narrow-to-field' can be
- ;; active when this function is called
- ;; from an change-functions hook. So
- ;; temporarily remove field narrowing
- ;; before to call `get-char-property'.
- (widen)
- (get-char-property (overlay-end overlay)
- 'field)))
- 'boundary))
- (or widget-field-add-space
- (null (widget-get widget :size))))
- (1- (overlay-end overlay))
- (overlay-end overlay))
+ ;; Don't proceed if overlay has been removed from buffer.
+ (when (overlay-buffer overlay)
+ (if (and (not (eq (with-current-buffer
+ (widget-field-buffer widget)
+ (save-restriction
+ ;; `widget-narrow-to-field' can be
+ ;; active when this function is called
+ ;; from an change-functions hook. So
+ ;; temporarily remove field narrowing
+ ;; before to call `get-char-property'.
+ (widen)
+ (get-char-property (overlay-end overlay)
+ 'field)))
+ 'boundary))
+ (or widget-field-add-space
+ (null (widget-get widget :size))))
+ (1- (overlay-end overlay))
+ (overlay-end overlay)))
(cdr overlay))))
(defun widget-field-find (pos)
:offset 0
:format-handler 'widget-default-format-handler
:button-face-get 'widget-default-button-face-get
+ :mouse-face-get 'widget-default-mouse-face-get
:sample-face-get 'widget-default-sample-face-get
:delete 'widget-default-delete
:copy 'identity
(widget-apply parent :button-face-get)
widget-button-face))))
+(defun widget-default-mouse-face-get (widget)
+ ;; Use :mouse-face or widget-mouse-face
+ (or (widget-get widget :mouse-face)
+ (let ((parent (widget-get widget :parent)))
+ (if parent
+ (widget-apply parent :mouse-face-get)
+ widget-mouse-face))))
+
(defun widget-default-sample-face-get (widget)
;; Use :sample-face.
(widget-get widget :sample-face))
(widget-princ-to-string (widget-get widget :value))))
(defun widget-default-active (widget)
- "Return t iff this widget active (user modifiable)."
+ "Return t if this widget is active (user modifiable)."
(or (widget-get widget :always-active)
(and (not (widget-get widget :inactive))
(let ((parent (widget-get widget :parent)))
;;; The `push-button' Widget.
;; (defcustom widget-push-button-gui t
-;; "If non nil, use GUI push buttons when available."
+;; "If non-nil, use GUI push buttons when available."
;; :group 'widgets
;; :type 'boolean)
;;; The `editable-field' Widget.
(define-widget 'editable-field 'default
- "An editable text field."
+ "An editable text field.
+Note: In an `editable-field' widget, the `%v' escape must be preceded
+by some other text in the `:format' string (if specified)."
:convert-widget 'widget-value-convert-widget
:keymap widget-field-keymap
:format "%v"
"History of field minibuffer edits.")
(defun widget-field-prompt-internal (widget prompt initial history)
- "Read string for WIDGET promptinhg with PROMPT.
+ "Read string for WIDGET prompting with PROMPT.
INITIAL is the initial input and HISTORY is a symbol containing
the earlier input."
(read-string prompt initial history))
(when sibling
(if (widget-value widget)
(widget-apply sibling :activate)
- (widget-apply sibling :deactivate)))))
+ (widget-apply sibling :deactivate))
+ (widget-clear-undo))))
;;; The `checklist' Widget.
;;; The `editable-list' Widget.
;; (defcustom widget-editable-list-gui nil
-;; "If non nil, use GUI push-buttons in editable list when available."
+;; "If non-nil, use GUI push-buttons in editable list when available."
;; :type 'boolean
;; :group 'widgets)
(defcustom widget-documentation-link-p 'intern-soft
"Predicate used to test if a string is useful as a link.
-The value should be a function. The function will be called one
+The value should be a function. The function will be called with one
argument, a string, and should return non-nil if there should be a
link for that string."
:type 'function
(define-widget 'file 'string
"A file widget.
-It will read a file name from the minibuffer when invoked."
+It reads a file name from an editable text field."
:complete-function 'widget-file-complete
:prompt-value 'widget-file-prompt-value
:format "%{%t%}: %v"
;; Fixme: use file-name-as-directory.
(define-widget 'directory 'file
"A directory widget.
-It will read a directory name from the minibuffer when invoked."
+It reads a directory name from an editable text field."
:tag "Directory")
(defvar widget-symbol-prompt-value-history nil
(widget-apply widget :notify widget event)
(widget-setup)))
\f
+;;; I'm not sure about what this is good for? KFS.
(defvar widget-key-sequence-prompt-value-history nil
"History of input to `widget-key-sequence-prompt-value'.")
-;; This mostly works, but I am pretty sure it needs more change
-;; to be 100% correct. I don't know what the change should be -- rms.
+(defvar widget-key-sequence-default-value [ignore]
+ "Default value for an empty key sequence.")
+
+(defvar widget-key-sequence-map
+ (let ((map (make-sparse-keymap)))
+ (set-keymap-parent map widget-field-keymap)
+ (define-key map [(control ?q)] 'widget-key-sequence-read-event)
+ map))
(define-widget 'key-sequence 'restricted-sexp
- "A Lisp function."
+ "A key sequence."
:prompt-value 'widget-field-prompt-value
:prompt-internal 'widget-symbol-prompt-internal
- :prompt-match 'fboundp
+; :prompt-match 'fboundp ;; What was this good for? KFS
:prompt-history 'widget-key-sequence-prompt-value-history
:action 'widget-field-action
:match-alternatives '(stringp vectorp)
- :validate (lambda (widget)
- (unless (or (stringp (widget-value widget))
- (vectorp (widget-value widget)))
- (widget-put widget :error (format "Invalid key sequence: %S"
- (widget-value widget)))
- widget))
- :value 'ignore
+ :format "%{%t%}: %v"
+ :validate 'widget-key-sequence-validate
+ :value-to-internal 'widget-key-sequence-value-to-internal
+ :value-to-external 'widget-key-sequence-value-to-external
+ :value widget-key-sequence-default-value
+ :keymap widget-key-sequence-map
+ :help-echo "C-q: insert KEY, EVENT, or CODE; RET: enter value"
:tag "Key sequence")
+
+(defun widget-key-sequence-read-event (ev)
+ (interactive (list
+ (let ((inhibit-quit t) quit-flag)
+ (read-event "Insert KEY, EVENT, or CODE: "))))
+ (let ((ev2 (and (memq 'down (event-modifiers ev))
+ (read-event)))
+ (tr (and (keymapp function-key-map)
+ (lookup-key function-key-map (vector ev)))))
+ (when (and (integerp ev)
+ (or (and (<= ?0 ev) (< ev (+ ?0 (min 10 read-quoted-char-radix))))
+ (and (<= ?a (downcase ev))
+ (< (downcase ev) (+ ?a -10 (min 36 read-quoted-char-radix))))))
+ (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)))
+ (insert (char-to-string ev)))) ;; throw invalid char error
+ (setq ev (key-description (list ev)))
+ (when (arrayp tr)
+ (setq tr (key-description (list (aref tr 0))))
+ (if (y-or-n-p (format "Key %s is translated to %s -- use %s? " ev tr tr))
+ (setq ev tr ev2 nil)))
+ (insert (if (= (char-before) ?\s) "" " ") ev " ")
+ (if ev2
+ (insert (key-description (list ev2)) " "))))
+
+(defun widget-key-sequence-validate (widget)
+ (unless (or (stringp (widget-value widget))
+ (vectorp (widget-value widget)))
+ (widget-put widget :error (format "Invalid key sequence: %S"
+ (widget-value widget)))
+ widget))
+
+(defun widget-key-sequence-value-to-internal (widget value)
+ (if (widget-apply widget :match value)
+ (if (equal value widget-key-sequence-default-value)
+ ""
+ (key-description value))
+ value))
+
+(defun widget-key-sequence-value-to-external (widget value)
+ (if (stringp value)
+ (if (string-match "\\`[[:space:]]*\\'" value)
+ widget-key-sequence-default-value
+ (read-kbd-macro value))
+ value))
+
\f
(define-widget 'sexp 'editable-field
"An arbitrary Lisp expression."
HCoop / bpt / emacs.git / blobdiff