xemacs-beta: lisp/custom/wid-edit.el comparison

comparison lisp/custom/wid-edit.el @ 165:5a88923fcbfe r20-3b9

Import from CVS: tag r20-3b9

author	cvs
date	Mon, 13 Aug 2007 09:44:42 +0200
parents	0132846995bd
children	85ec50267440

comparison

equal deleted inserted replaced

-:4e0740e5aab2
+:5a88923fcbfe
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.9931
+;; Version: 1.9937
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;; This file is part of GNU Emacs.
 ;; GNU Emacs is free software; you can redistribute it and/or modify
 (defgroup widget-faces nil
 "Faces used by the widget library."
 :group 'widgets
 :group 'faces)
+(defvar widget-documentation-face 'widget-documentation-face
+"Face used for documentation strings in widges.
+This exists as a variable so it can be set locally in certain buffers.")
 (defface widget-documentation-face '((((class color)
 				       (background dark))
 				      (:foreground "lime green"))
 				     (((class color)
 				       (background light))
 (defcustom widget-menu-max-size 40
 "Largest number of items allowed in a popup-menu.
 Larger menus are read through the minibuffer."
 :group 'widgets
 :type 'integer)
+(defcustom widget-menu-minibuffer-flag nil
+"*Control how to ask for a choice from the keyboard.
+Non-nil means use the minibuffer;
+nil means read a single character."
+:group 'widgets
+:type 'boolean)
 (defun widget-choose (title items &optional event)
 "Choose an item from a list.
 First argument TITLE is the name of the list.
 	   (setq val (and val
 			  (listp (event-object val))
 			  (stringp (car-safe (event-object val)))
 			  (car (event-object val))))
 	   (cdr (assoc val items))))
-	(t
+	(widget-menu-minibuffer-flag
+	 ;; Read the choice of name from the minibuffer.
 	 (setq items (widget-remove-if 'stringp items))
 	 (let ((val (completing-read (concat title ": ") items nil t)))
 	   (if (stringp val)
 	       (let ((try (try-completion val items)))
 		 (when (stringp try)
 		   (setq val try))
 		 (cdr (assoc val items)))
-	     nil)))))
+	     nil)))
+	(t
+	 ;; Construct a menu of the choices
+	 ;; and then use it for prompting for a single character.
+	 (let* ((overriding-terminal-local-map
+		 (make-sparse-keymap))
+		map choice (next-digit ?0)
+		value)
+	   ;; Define SPC as a prefix char to get to this menu.
+	   (define-key overriding-terminal-local-map " "
+	     (setq map (make-sparse-keymap title)))
+	   (while items
+	     (setq choice (car items) items (cdr items))
+	     (if (consp choice)
+		 (let* ((name (car choice))
+		       (function (cdr choice))
+		       (character (aref name 0)))
+		   ;; Pick a character for this choice;
+		   ;; avoid duplication.
+		   (when (lookup-key map (vector character))
+		     (setq character (downcase character))
+		     (when (lookup-key map (vector character))
+		       (setq character next-digit
+			     next-digit (1+ next-digit))))
+		   (define-key map (vector character)
+		     (cons (format "%c = %s" character name) function)))))
+	   (define-key map [?\C-g] '("Quit" . keyboard-quit))
+	   (define-key map [t] 'keyboard-quit)
+	   (setcdr map (nreverse (cdr map)))
+	   ;; Unread a SPC to lead to our new menu.
+	   (setq unread-command-events (cons ?\ unread-command-events))
+	   ;; Read a char with the menu, and return the result
+	   ;; that corresponds to it.
+	   (setq value
+		 (lookup-key overriding-terminal-local-map
+			     (read-key-sequence title) t))
+	   (when (eq value 'keyboard-quit)
+	     (error "Canceled"))
+	   value))))
 (defun widget-remove-if (predictate list)
 (let (result (tail list))
 (while tail
 (or (funcall predictate (car tail))
 "Non-nil means add extra space at the end of editable text fields.
 This is needed on all versions of Emacs, and on XEmacs before 20.3.
 If you don't add the space, it will become impossible to edit a zero
 size field."
+:type 'boolean
+:group 'widgets)
+(defcustom widget-field-use-before-change
+(or (> emacs-minor-version 34)
+(> emacs-major-version 20)
+(string-match "XEmacs" emacs-version))
+"Non-nil means use `before-change-functions' to track editable fields.
+This enables the use of undo, but doesn'f work on Emacs 19.34 and earlier.
+Using before hooks also means that the :notify function can't know the
+new value."
 :type 'boolean
 :group 'widgets)
 (defun widget-specify-field (widget from to)
 "Specify editable button for WIDGET between FROM and TO."
 					 'end-open t
 					 'face face)))))
 (defun widget-specify-doc (widget from to)
 ;; Specify documentation for WIDGET between FROM and TO.
 (add-text-properties from to (list 'widget-doc widget
-				     'face 'widget-documentation-face)))
+				     'face widget-documentation-face)))
 (defmacro widget-specify-insert (&rest form)
 ;; Execute FORM without inheriting any text properties.
 (`
 (save-restriction
 		       (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)))
-	     (let (command up)
+	     (let ((up t)
+		   command)
 	       ;; Find the global command to run, and check whether it
 	       ;; is bound to an up event.
 	       (cond ((setq command	;down event
-			    (lookup-key widget-global-map [ button2 ])))
+			    (lookup-key widget-global-map [ button2 ]))
+		      (setq up nil))
 		     ((setq command	;down event
-			    (lookup-key widget-global-map [ down-mouse-2 ])))
+			    (lookup-key widget-global-map [ down-mouse-2 ]))
+		      (setq up nil))
 		     ((setq command	;up event
-			    (lookup-key widget-global-map [ button2up ]))
+			    (lookup-key widget-global-map [ button2up ])))
-		      (setq up t))
 		     ((setq command	;up event
-			    (lookup-key widget-global-map [ mouse-2]))
+			    (lookup-key widget-global-map [ mouse-2]))))
-		      (setq up t)))
+	       (when up
+		 ;; Don't execute up events twice.
+		 (while (not (button-release-event-p event))
+		   (setq event (widget-read-event))))
 	       (when command
-		 ;; Don't execute up events twice.
-		 (when up
-		   (while (not (button-release-event-p event))
-		     (setq event (widget-read-event))))
 		 (call-interactively command))))))
 	(t
 	 (message "You clicked somewhere weird."))))
 (defun widget-button1-click (event)
 	(set-marker from nil)
 	(set-marker to nil))))
 (widget-clear-undo)
 ;; We need to maintain text properties and size of the editing fields.
 (make-local-variable 'after-change-functions)
-(make-local-variable 'before-change-functions)
 (setq after-change-functions
 	(if widget-field-list '(widget-after-change) nil))
-(setq before-change-functions
+(when widget-field-use-before-change
-	(if widget-field-list '(widget-before-change) nil)))
+(make-local-variable 'before-change-functions)
+(setq before-change-functions
+	  (if widget-field-list '(widget-before-change) nil))))
 (defvar widget-field-last nil)
 ;; Last field containing point.
 (make-variable-buffer-local 'widget-field-last)
 		     buttons))))
 	  (t
 	   (error "Unknown escape `%c'" escape)))
 (widget-put widget :buttons buttons)))
+(defvar widget-button-face nil
+"Face to use for buttons.
+This is a variable so that it can be buffer-local.")
 (defun widget-default-button-face-get (widget)
 ;; Use :button-face or widget-button-face
-(or (widget-get widget :button-face) 'widget-button-face))
+(or (widget-get widget :button-face)
+(let ((parent (widget-get widget :parent)))
+	(if parent
+	    (widget-apply parent :button-face-get)
+	  'widget-button-face))))
 (defun widget-default-sample-face-get (widget)
 ;; Use :sample-face.
 (widget-get widget :sample-face))
 (set-marker to nil))
 (widget-clear-undo))
 (defun widget-default-value-set (widget value)
 ;; Recreate widget with new value.
-(save-excursion
+(let* ((old-pos (point))
-(goto-char (widget-get widget :from))
+	 (from (copy-marker (widget-get widget :from)))
-(widget-apply widget :delete)
+	 (to (copy-marker (widget-get widget :to)))
-(widget-put widget :value value)
+	 (offset (if (and (<= from old-pos) (<= old-pos to))
-(widget-apply widget :create)))
+		     (if (>= old-pos (1- to))
+			 (- old-pos to 1)
+		       (- old-pos from)))))
+;;??? Bug: this ought to insert the new value before deleting the old one,
+;; so that markers on either side of the value automatically
+;; stay on the same side.  -- rms.
+(save-excursion
+(goto-char (widget-get widget :from))
+(widget-apply widget :delete)
+(widget-put widget :value value)
+(widget-apply widget :create))
+(if offset
+	(if (< offset 0)
+	    (goto-char (+ (widget-get widget :to) offset 1))
+	  (goto-char (min (+ from offset) (1- (widget-get widget :to))))))))
 (defun widget-default-value-inline (widget)
 ;; Wrap value in a list unless it is inline.
 (if (widget-get widget :inline)
 (widget-value widget)
 	(history (widget-get widget :prompt-history)))
 (let ((answer (widget-apply widget
 				:prompt-internal prompt initial history)))
 (widget-apply widget :value-to-external answer))))
+(defvar widget-edit-functions nil)
 (defun widget-field-action (widget &optional event)
-;; Edit the value in the minibuffer.
+;; Move to next field.
-(let ((invalid (widget-apply widget :validate)))
+(widget-forward 1)
-(let ((prompt (concat (widget-apply widget :menu-tag-get) ": "))
+(run-hook-with-args 'widget-edit-functions widget))
-	  (value (unless invalid
-		   (widget-value widget))))
-(let ((answer (widget-apply widget :prompt-value prompt value invalid) ))
-	(widget-value-set widget answer)))
-(widget-setup)
-(widget-apply widget :notify widget event)))
 (defun widget-field-validate (widget)
 ;; Valid if the content matches `:valid-regexp'.
 (save-excursion
 (let ((value (widget-apply widget :value-get))
 (when current
 (widget-value-set widget
 			(widget-apply current :value-to-external
 				      (widget-get current :value)))
 (widget-setup)
-(widget-apply widget :notify widget event))))
+(widget-apply widget :notify widget event)))
+(run-hooks 'widget-edit-hook))
 (defun widget-choice-validate (widget)
 ;; Valid if we have made a valid choice.
 (let ((void (widget-get widget :void))
 	(choice (widget-get widget :choice))
 			 (widget-get widget :off-glyph))))
 (defun widget-toggle-action (widget &optional event)
 ;; Toggle value.
 (widget-value-set widget (not (widget-value widget)))
-(widget-apply widget :notify widget event))
+(widget-apply widget :notify widget event)
+(run-hooks 'widget-edit-hook))
 ;;; The `checkbox' Widget.
 (define-widget 'checkbox 'toggle
 "A checkbox toggle."
 (defun widget-documentation-link-echo-help (widget)
 "Tell what this link will describe."
 (concat "Describe the `" (widget-get widget :value) "' symbol."))
 (defun widget-documentation-link-action (widget &optional event)
-"Run apropos on WIDGET's value.  Ignore optional argument EVENT."
+"Display documentation for WIDGET's value.  Ignore optional argument EVENT."
-(apropos (concat "\\`" (regexp-quote (widget-get widget :value)) "\\'")))
+(let* ((string (widget-get widget :value))
+	 (symbol (intern string)))
+(if (and (fboundp symbol) (boundp symbol))
+	;; If there are two doc strings, give the user a way to pick one.
+	(apropos (concat "\\`" (regexp-quote string) "\\'"))
+(if (fboundp symbol)
+	  (describe-function symbol)
+	(describe-variable symbol)))))
 (defcustom widget-documentation-links t
 "Add hyperlinks to documentation strings when non-nil."
 :type 'boolean
 :group 'widget-documentation)
 	     widget))))
 (define-widget 'file 'string
 "A file widget.
 It will read a file name from the minibuffer when invoked."
+:complete-function 'widget-file-complete
 :prompt-value 'widget-file-prompt-value
 :format "%{%t%}: %v"
-:tag "File"
+:tag "File")
-:action 'widget-file-action)
+(defun widget-file-complete ()
+"Perform completion on file name preceding point."
+(interactive)
+(let* ((end (point))
+	 (beg (save-excursion
+		(skip-chars-backward "^ ")
+		(point)))
+	 (pattern (buffer-substring beg end))
+	 (name-part (file-name-nondirectory pattern))
+	 (directory (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...")
+	   (let ((list (file-name-all-completions name-part directory)))
+	     (setq list (sort list 'string<))
+	     (with-output-to-temp-buffer "*Completions*"
+	       (display-completion-list list)))
+	   (message "Making completion list...%s" "done")))))
 (defun widget-file-prompt-value (widget prompt value unbound)
 ;; Read file from minibuffer.
 (abbreviate-file-name
 (if unbound
 	   (dir (file-name-directory value))
 	   (file (file-name-nondirectory value))
 	   (must-match (widget-get widget :must-match)))
 (read-file-name prompt2 dir nil must-match file)))))
-(defun widget-file-action (widget &optional event)
+;;;(defun widget-file-action (widget &optional event)
-;; Read a file name from the minibuffer.
+;;;  ;; Read a file name from the minibuffer.
-(let* ((value (widget-value widget))
+;;;  (let* ((value (widget-value widget))
-	 (dir (file-name-directory value))
+;;;	 (dir (file-name-directory value))
-	 (file (file-name-nondirectory value))
+;;;	 (file (file-name-nondirectory value))
-	 (menu-tag (widget-apply widget :menu-tag-get))
+;;;	 (menu-tag (widget-apply widget :menu-tag-get))
-	 (must-match (widget-get widget :must-match))
+;;;	 (must-match (widget-get widget :must-match))
-	 (answer (read-file-name (concat menu-tag ": (default `" value "') ")
+;;;	 (answer (read-file-name (concat menu-tag ": (default `" value "') ")
-				 dir nil must-match file)))
+;;;				 dir nil must-match file)))
-(widget-value-set widget (abbreviate-file-name answer))
+;;;    (widget-value-set widget (abbreviate-file-name answer))
-(widget-setup)
+;;;    (widget-setup)
-(widget-apply widget :notify widget event)))
+;;;    (widget-apply widget :notify widget event)))
 (define-widget 'directory 'file
 "A directory widget.
 It will read a directory name from the minibuffer when invoked."
 :tag "Directory")
 "A lisp symbol."
 :value nil
 :tag "Symbol"
 :format "%{%t%}: %v"
 :match (lambda (widget value) (symbolp value))
+:complete-function 'lisp-complete-symbol
 :prompt-internal 'widget-symbol-prompt-internal
 :prompt-match 'symbolp
 :prompt-history 'widget-symbol-prompt-value-history
 :value-to-internal (lambda (widget value)
 		       (if (symbolp value)
 	  (unless (eobp)
 	    (error "Junk at end of expression: %s"
 		   (buffer-substring (point) (point-max))))
 	  answer)))))
-(define-widget 'integer 'sexp
+(define-widget 'restricted-sexp 'sexp
+"A Lisp expression restricted to values that match.
+To use this type, you must define :match or :match-alternatives."
+:type-error "The specified value is not valid"
+:match 'widget-restricted-sexp-match
+:value-to-internal (lambda (widget value)
+		       (if (widget-apply widget :match value)
+			   (prin1-to-string value)
+			 value)))
+(defun widget-restricted-sexp-match (widget value)
+(let ((alternatives (widget-get widget :match-alternatives))
+	matched)
+(while (and alternatives (not matched))
+(if (cond ((functionp (car alternatives))
+		 (funcall (car alternatives) value))
+		((and (consp (car alternatives))
+		      (eq (car (car alternatives)) 'quote))
+		 (eq value (nth 1 (car alternatives)))))
+	  (setq matched t))
+(setq alternatives (cdr alternatives)))
+matched))
+(define-widget 'integer 'restricted-sexp
 "An integer."
 :tag "Integer"
 :value 0
 :type-error "This field should contain an integer"
-:value-to-internal (lambda (widget value)
+:match-alternatives '(integerp))
-		       (if (integerp value)
-			   (prin1-to-string value)
+(define-widget 'number 'restricted-sexp
-			 value))
+"A floating point number."
-:match (lambda (widget value) (integerp value)))
+:tag "Number"
+:value 0.0
+:type-error "This field should contain a number"
+:match-alternatives '(numberp))
 (define-widget 'character 'editable-field
-"An character."
+"A character."
 :tag "Character"
 :value 0
 :size 1
 :format "%{%t%}: %v\n"
 :valid-regexp "\\`.\\'"
 			 value))
 :match (lambda (widget value)
 	   (if (fboundp 'characterp)
 	       (characterp value)
 	     (integerp value))))
-(define-widget 'number 'sexp
-"A floating point number."
-:tag "Number"
-:value 0.0
-:type-error "This field should contain a number"
-:value-to-internal (lambda (widget value)
-		       (if (numberp value)
-			   (prin1-to-string value)
-			 value))
-:match (lambda (widget value) (numberp value)))
 (define-widget 'list 'group
 "A lisp list."
 :tag "List"
 :format "%{%t%}:\n%v")

Mercurial > hg > xemacs-beta

comparison lisp/custom/wid-edit.el @ 165:5a88923fcbfe r20-3b9