emacs: lisp/wid-edit.el comparison

comparison lisp/wid-edit.el @ 90261:7beb78bc1f8e

Revision: miles@gnu.org--gnu-2005/emacs--unicode--0--patch-97 Merge from emacs--cvs-trunk--0 Patches applied: * emacs--cvs-trunk--0 (patch 616-696) - Add lisp/mh-e/.arch-inventory - Update from CVS - Merge from gnus--rel--5.10 - Update from CVS: lisp/smerge-mode.el: Add 'tools' to file keywords. - lisp/gnus/ChangeLog: Remove duplicate entry * gnus--rel--5.10 (patch 147-181) - Update from CVS - Merge from emacs--cvs-trunk--0 - Update from CVS: lisp/mml.el (mml-preview): Doc fix. - Update from CVS: texi/message.texi: Fix default values. - Update from CVS: texi/gnus.texi (RSS): Addition.

author	Miles Bader <miles@gnu.org>
date	Mon, 16 Jan 2006 08:37:27 +0000
parents	0ca0d9181b5e ca3d61094d2b
children	7432ca837c8d

comparison

equal deleted inserted replaced

-:0ca0d9181b5e
+:7beb78bc1f8e
 (overlay-put overlay 'keymap (widget-get widget :keymap))
 (overlay-put overlay 'evaporate t)
 ;; 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))
-; Text terminals cannot change mouse pointer shape, so use mouse
+(overlay-put overlay 'mouse-face
-; face instead.
+		   (widget-apply widget :mouse-face-get)))
-(or (display-graphic-p)
-	  (overlay-put overlay 'mouse-face widget-mouse-face)))
 (overlay-put overlay 'pointer 'hand)
 (overlay-put overlay 'follow-link follow-link)
 (overlay-put overlay 'help-echo help-echo)))
 (defun widget-mouse-help (window overlay point)
 (defun widget-move-and-invoke (event)
 "Move to where you click, and if it is an active field, invoke it."
 (interactive "e")
 (mouse-set-point event)
-(if (widget-event-point event)
+(let ((pos (widget-event-point event)))
-(let* ((pos (widget-event-point event))
+(if (and pos (get-char-property pos 'button))
-	     (button (get-char-property pos 'button)))
+	(widget-button-click event))))
-	(if button
-	    (widget-button-click event)))))
 ;;; Buttons.
 (defgroup widget-button nil
 "The look of various kinds of buttons."
 ;;;###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)] 'widget-backward)
 (define-key map [backtab] 'widget-backward)
 (define-key map [down-mouse-2] 'widget-button-click)
 (define-key map "\C-m" 'widget-button-press)
 map)
 (let ((overlay (widget-get widget :field-overlay)))
 ;; Don't subtract one if local-map works at the end of the overlay,
 ;; or if a special `boundary' field has been added after the widget
 ;; field.
 (if (overlayp overlay)
-	(if (and (not (eq (with-current-buffer
+;; Don't proceed if overlay has been removed from buffer.
-			      (widget-field-buffer widget)
+(when (overlay-buffer overlay)
-			    (save-restriction
+(if (and (not (eq (with-current-buffer
-			      ;; `widget-narrow-to-field' can be
+(widget-field-buffer widget)
-			      ;; active when this function is called
+(save-restriction
-			      ;; from an change-functions hook. So
+;; `widget-narrow-to-field' can be
-			      ;; temporarily remove field narrowing
+;; active when this function is called
-			      ;; before to call `get-char-property'.
+;; from an change-functions hook. So
-			      (widen)
+;; temporarily remove field narrowing
-			      (get-char-property (overlay-end overlay)
+;; before to call `get-char-property'.
-						 'field)))
+(widen)
-			  'boundary))
+(get-char-property (overlay-end overlay)
-		 (or widget-field-add-space
+'field)))
-		     (null (widget-get widget :size))))
+'boundary))
-	    (1- (overlay-end overlay))
+(or widget-field-add-space
-	  (overlay-end overlay))
+(null (widget-get widget :size))))
+(1- (overlay-end overlay))
+(overlay-end overlay)))
 (cdr overlay))))
 (defun widget-field-find (pos)
 "Return the field at POS.
 Unlike (get-char-property POS 'field), this works with empty fields too."
 :create 'widget-default-create
 :indent nil
 :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
 :value-set 'widget-default-value-set
 :value-inline 'widget-default-value-inline
 (let ((parent (widget-get widget :parent)))
 	(if parent
 	    (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))
 (defun widget-default-delete (widget)
 (widget-toggle-action widget event)
 (let ((sibling (widget-get-sibling widget)))
 (when sibling
 (if (widget-value widget)
 	  (widget-apply sibling :activate)
-	(widget-apply sibling :deactivate)))))
+	(widget-apply sibling :deactivate))
+(widget-clear-undo))))
 ;;; The `checklist' Widget.
 (define-widget 'checklist 'default
 "A multiple choice widget."
 (error (widget-put widget :error (error-message-string data))
 	   widget)))
 (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"
 ;; Doesn't work well with terminating newline.
 ;; :value-face 'widget-single-line-field
 ;;;    (widget-apply widget :notify widget event)))
 ;; 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
 "History of input to `widget-symbol-prompt-value'.")
 	  (widget-value widget)
 	  t)))
 (widget-value-set widget answer)
 (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'.")
+(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 key sequence."
+:prompt-value 'widget-field-prompt-value
+:prompt-internal 'widget-symbol-prompt-internal
+; :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)
+: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."
 :tag "Lisp expression"
 :format "%{%t%}: %v"
 ;;; The `color' Widget.
 ;; Fixme: match
 (define-widget 'color 'editable-field
 "Choose a color name (with sample)."
-:format "%t: %v (%{sample%})\n"
+:format "%{%t%}: %v (%{sample%})\n"
 :size 10
 :tag "Color"
 :value "black"
 :complete 'widget-color-complete
 :sample-face-get 'widget-color-sample-face-get

Mercurial > emacs

comparison lisp/wid-edit.el @ 90261:7beb78bc1f8e