X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/ce4374c7dcc9e53f6063e562dc3cb69b3e514057..4837b516ea56c6cc2b3ce823b04078b10b2defc6:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 0df0b7365d..6725144e68 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 Free Software Foundation, Inc. +;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Maintainer: FSF @@ -11,7 +11,7 @@ ;; 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, @@ -84,7 +84,7 @@ :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 @@ -275,14 +275,15 @@ minibuffer." 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))) @@ -403,7 +404,8 @@ new value.") ;; 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))) @@ -481,7 +483,7 @@ new value.") ;;;###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) @@ -498,7 +500,7 @@ Otherwise, just return the value." 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) @@ -597,7 +599,7 @@ automatically." :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) @@ -848,13 +850,18 @@ button end points." ;;; 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. @@ -906,75 +913,94 @@ Recommended as a parent keymap for modes using 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)) @@ -1201,22 +1227,24 @@ When not inside a field, move to the previous button or field." ;; 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) @@ -1390,6 +1418,7 @@ The value of the :type attribute should be an unconverted widget type." :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 @@ -1534,6 +1563,14 @@ If that does not exists, call the value of `widget-complete-field'." (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)) @@ -1604,7 +1641,7 @@ If that does not exists, call the value of `widget-complete-field'." (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))) @@ -1683,7 +1720,7 @@ If END is omitted, it defaults to the length of LIST." ;;; 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) @@ -1815,7 +1852,9 @@ If END is omitted, it defaults to the length of LIST." ;;; 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" @@ -1837,7 +1876,7 @@ If END is omitted, it defaults to the length of LIST." "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)) @@ -2160,7 +2199,8 @@ when he invoked the menu." (when sibling (if (widget-value widget) (widget-apply sibling :activate) - (widget-apply sibling :deactivate))))) + (widget-apply sibling :deactivate)) + (widget-clear-undo)))) ;;; The `checklist' Widget. @@ -2525,7 +2565,7 @@ Return an alist of (TYPE MATCH)." ;;; 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) @@ -2827,7 +2867,7 @@ The first group should be the link itself." (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 @@ -2986,7 +3026,7 @@ as the value." (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" @@ -3048,7 +3088,7 @@ It will read a file name from the minibuffer when invoked." ;; 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 @@ -3159,28 +3199,83 @@ It will read a directory name from the minibuffer when invoked." (widget-apply widget :notify widget event) (widget-setup))) +;;; 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)) + (define-widget 'sexp 'editable-field "An arbitrary Lisp expression."