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

comparison lisp/custom/wid-edit.el @ 155:43dd3413c7c7 r20-3b4

Import from CVS: tag r20-3b4

author	cvs
date	Mon, 13 Aug 2007 09:39:39 +0200
parents	25f70ba0133c
children	6b37e6ddd302

comparison

equal deleted inserted replaced

-:94141801dd7e
+:43dd3413c7c7
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.98
+;; Version: 1.9907
 ;; 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
 ;; See `widget.el'.
 ;;; Code:
 (require 'widget)
-(require 'cl)
+(eval-when-compile (require 'cl))
 ;;; Compatibility.
 (eval-and-compile
 (autoload 'pp-to-string "pp")
 (when (string-match "XEmacs" emacs-version)
 (condition-case nil
 	(require 'overlay)
 (error (load-library "x-overlay"))))
-(if (string-match "XEmacs" emacs-version)
-;; XEmacs spell `intangible' as `atomic'.
-(defun widget-make-intangible (from to side)
-	"Make text between FROM and TO atomic with regard to movement.
-Third argument should be `start-open' if it should be sticky to the rear,
-and `end-open' if it should sticky to the front."
-	(require 'atomic-extents)
-	(let ((ext (make-extent from to)))
-	   ;; XEmacs doesn't understant different kinds of read-only, so
-	   ;; we have to use extents instead.
-	  (put-text-property from to 'read-only nil)
-	  (set-extent-property ext 'read-only t)
-	  (set-extent-property ext 'start-open nil)
-	  (set-extent-property ext 'end-open nil)
-	  (set-extent-property ext side t)
-	  (set-extent-property ext 'atomic t)))
-(defun widget-make-intangible (from to size)
-"Make text between FROM and TO intangible."
-(put-text-property from to 'intangible 'front)))
 (if (string-match "XEmacs" emacs-version)
 (defun widget-event-point (event)
 	"Character position of the end of event if that exists, or nil."
 	(if (mouse-event-p event)
 	    (event-point event)
 	  nil))
 (defun widget-event-point (event)
 "Character position of the end of event if that exists, or nil."
 (posn-point (event-end event))))
-;; The following should go away when bundled with Emacs.
+(defalias 'widget-read-event (if (string-match "XEmacs" emacs-version)
+				   'next-event
+				 'read-event))
+;; The following should go away when bundled with Emacs.
 (condition-case ()
 (require 'custom)
 (error nil))
 (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
 (let ((buf (get-buffer-create " *error-message*")))
 	(erase-buffer buf)
 	(display-error obj buf)
 	(buffer-string buf)))))
+(when (let ((a "foo"))
+	(put-text-property 1 2 'foo 1 a)
+	(put-text-property 1 2 'bar 2 a)
+	(set-text-properties 1 2 nil a)
+	(text-properties-at 1 a))
+;; XEmacs 20.2 and earlier had a buggy set-text-properties.
+(defun set-text-properties (start end props &optional buffer-or-string)
+"Completely replace properties of text from START to END.
+The third argument PROPS is the new property list.
+The optional fourth argument, BUFFER-OR-STRING,
+is the string or buffer containing the text."
+(map-extents #'(lambda (extent ignored)
+		     (remove-text-properties
+		      start end
+		      (list (extent-property extent 'text-prop)
+			    nil)
+		      buffer-or-string)
+		     nil)
+		 buffer-or-string start end nil nil 'text-prop)
+(add-text-properties start end props buffer-or-string)))
 ;;; Customization.
 (defgroup widgets nil
 "Customization support for the Widget Library."
 :link '(custom-manual "(widget)Top")
 		   "http://www.dina.kvl.dk/~abraham/custom/")
 :prefix "widget-"
 :group 'extensions
 :group 'faces
 :group 'hypermedia)
-(defface widget-documentation-face '((((class color)
-				       (background dark))
-				      (:foreground "lime green"))
-				     (((class color)
-				       (background light))
-				      (:foreground "dark green"))
-				     (t nil))
-"Face used for documentation text."
-:group 'widgets)
 (defface widget-button-face '((t (:bold t)))
 "Face used for widget buttons."
 :group 'widgets)
 			  (listp (event-object val))
 			  (stringp (car-safe (event-object val)))
 			  (car (event-object val))))
 	   (cdr (assoc val items))))
 	(t
-	 (setq items (remove-if 'stringp items))
+	 (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)))))
+(defun widget-remove-if (predictate list)
+(let (result (tail list))
+(while tail
+(or (funcall predictate (car tail))
+	  (setq result (cons (car tail) result)))
+(setq tail (cdr tail)))
+(nreverse result)))
 ;;; Widget text specifications.
 ;;
 ;; These functions are for specifying text properties.
 (defun widget-specify-none (from to)
 (defun widget-specify-text (from to)
 ;; Default properties.
 (add-text-properties from to (list 'read-only t
 				     'front-sticky t
-				     'start-open t
+				     'rear-nonsticky nil
-				     'end-open t
+				     'start-open nil
-				     'rear-nonsticky nil)))
+				     'end-open nil)))
 (defun widget-specify-field (widget from to)
-;; Specify editable button for WIDGET between FROM and TO.
+"Specify editable button for WIDGET between FROM and TO."
-(widget-specify-field-update widget from to)
+(put-text-property from to 'read-only nil)
+;; Terminating space is not part of the field, but necessary in
-;; Make it possible to edit the front end of the field.
+;; order for local-map to work.  Remove next sexp if local-map works
-(add-text-properties (1- from) from (list 'rear-nonsticky t
+;; at the end of the overlay.
-					      'end-open t
+(save-excursion
-					      'invisible t))
+(goto-char to)
-(when (or (string-match "\\(.\\|\n\\)%v" (widget-get widget :format))
+(insert-and-inherit " ")
-	    (widget-get widget :hide-front-space))
+(setq to (point)))
-;; WARNING: This is going to lose horrible if the character just
+(add-text-properties (1- to) to ;to (1+ to)
-;; before the field can be modified (e.g. if it belongs to a
+		       '(front-sticky nil start-open t read-only to))
-;; choice widget).  We try to compensate by checking the format
+(add-text-properties (1- from) from
-;; string, and hope the user hasn't changed the :create method.
+		       '(rear-nonsticky t end-open t read-only from))
-(widget-make-intangible (- from 2) from 'end-open))
-;; Make it possible to edit back end of the field.
-(add-text-properties to (1+ to) (list 'front-sticky nil
-					'read-only t
-					'start-open t))
-(cond ((widget-get widget :size)
-	 (put-text-property to (1+ to) 'invisible t)
-	 (when (or (string-match "%v\\(.\\|\n\\)" (widget-get widget :format))
-		   (widget-get widget :hide-rear-space))
-	   ;; WARNING: This is going to lose horrible if the character just
-	   ;; after the field can be modified (e.g. if it belongs to a
-	   ;; choice widget).  We try to compensate by checking the format
-	   ;; string, and hope the user hasn't changed the :create method.
-	   (widget-make-intangible to (+ to 2) 'start-open)))
-	((string-match "XEmacs" emacs-version)
-	 ;; XEmacs does not allow you to insert before a read-only
-	 ;; character, even if it is start.open.
-	 ;; XEmacs does allow you to delete an read-only extent, so
-	 ;; making the terminating newline read only doesn't help.
-	 ;; I tried putting an invisible intangible read-only space
-	 ;; before the newline, which gave really weird effects.
-	 ;; So for now, we just have trust the user not to delete the
-	 ;; newline.
-	 (put-text-property to (1+ to) 'read-only nil))))
-(defun widget-specify-field-update (widget from to)
-;; Specify editable button for WIDGET between FROM and TO.
 (let ((map (widget-get widget :keymap))
-	(secret (widget-get widget :secret))
+	(face (or (widget-get widget :value-face) 'widget-field-face))
-	(secret-to to)
-	(size (widget-get widget :size))
-	(face (or (widget-get widget :value-face)
-		  'widget-field-face))
 	(help-echo (widget-get widget :help-echo))
-	(help-property (if (featurep 'balloon-help)
+	(overlay (make-overlay from to nil nil t)))
-			   'balloon-help
-			 'help-echo)))
 (unless (or (stringp help-echo) (null help-echo))
 (setq help-echo 'widget-mouse-help))
+(widget-put widget :field-overlay overlay)
-(when secret
+(overlay-put overlay 'detachable nil)
-(while (and size
+(overlay-put overlay 'field widget)
-		  (not (zerop size))
+(overlay-put overlay 'local-map map)
-		  (> secret-to from)
+(overlay-put overlay 'keymap map)
-		  (eq (char-after (1- secret-to)) ?\ ))
+(overlay-put overlay 'face face)
-	(setq secret-to (1- secret-to)))
+(overlay-put overlay 'balloon-help help-echo)
+(overlay-put overlay 'help-echo help-echo)))
-(save-excursion
-	(goto-char from)
-	(while (< (point) secret-to)
-	  (let ((old (get-text-property (point) 'secret)))
-	    (when old
-	      (subst-char-in-region (point) (1+ (point)) secret old)))
-	  (forward-char))))
-(set-text-properties from to (list 'field widget
-				       'read-only nil
-				       'keymap map
-				       'local-map map
-				       help-property help-echo
-				       'face face))
-(when secret
-(save-excursion
-	(goto-char from)
-	(while (< (point) secret-to)
-	  (let ((old (following-char)))
-	    (subst-char-in-region (point) (1+ (point)) old secret)
-	    (put-text-property (point) (1+ (point)) 'secret old))
-	  (forward-char))))
-(unless (widget-get widget :size)
-(add-text-properties to (1+ to) (list 'field widget
-					    help-property help-echo
-					    'face face)))
-(add-text-properties to (1+ to) (list 'local-map map
-					  'keymap map))))
 (defun widget-specify-button (widget from to)
-;; Specify button for WIDGET between FROM and TO.
+"Specify button for WIDGET between FROM and TO."
 (let ((face (widget-apply widget :button-face-get))
 	(help-echo (widget-get widget :help-echo))
-	(help-property (if (featurep 'balloon-help)
+	(overlay (make-overlay from to nil t nil)))
-			   'balloon-help
+(widget-put widget :button-overlay overlay)
-			 'help-echo)))
 (unless (or (null help-echo) (stringp help-echo))
 (setq help-echo 'widget-mouse-help))
-(add-text-properties from to (list 'button widget
+(overlay-put overlay 'button widget)
-				       'mouse-face widget-mouse-face
+(overlay-put overlay 'mouse-face widget-mouse-face)
-				       'start-open t
+(overlay-put overlay 'balloon-help help-echo)
-				       'end-open t
+(overlay-put overlay 'help-echo help-echo)
-				       help-property help-echo
+(overlay-put overlay 'face face)))
-				       'face face))))
 (defun widget-mouse-help (extent)
 "Find mouse help string for button in extent."
 (let* ((widget (widget-at (extent-start-position extent)))
 	 (help-echo (and widget (widget-get widget :help-echo))))
 (defun widget-specify-inactive (widget from to)
 "Make WIDGET inactive for user modifications."
 (unless (widget-get widget :inactive)
 (let ((overlay (make-overlay from to nil t nil)))
 (overlay-put overlay 'face 'widget-inactive-face)
+(overlay-put overlay 'mouse-face 'widget-inactive-face)
 (overlay-put overlay 'evaporate t)
 (overlay-put overlay 'priority 100)
 (overlay-put overlay (if (string-match "XEmacs" emacs-version)
 			       'read-only
 			     'modification-hooks) '(widget-overlay-inactive))
 	 (cons (list (car vals)) (cdr vals)))
 	(t nil)))
 (defun widget-apply-action (widget &optional event)
 "Apply :action in WIDGET in response to EVENT."
-(if (widget-apply widget :active)
+(let (after-change-functions)
-(widget-apply widget :action event)
+(if (widget-apply widget :active)
-(error "Attempt to perform action on inactive widget")))
+	(widget-apply widget :action event)
+(error "Attempt to perform action on inactive widget"))))
 ;;; Helper functions.
 ;;
 ;; These are widget specific.
 :type '(repeat (cons :format "%v"
 		       (symbol :tag "Image Format" unknown)
 		       (repeat :tag "Suffixes"
 			       (string :format "%v")))))
-(defun widget-glyph-insert (widget tag image)
+(defun widget-glyph-find (image tag)
-"In WIDGET, insert the text TAG or, if supported, IMAGE.
+"Create a glyph corresponding to IMAGE with string TAG as fallback.
-IMAGE should either be a glyph, an image instantiator, or an image file
+IMAGE should either already be a glyph, or be a file name sans
-name sans extension (xpm, xbm, gif, jpg, or png) located in
+extension (xpm, xbm, gif, jpg, or png) located in
-`widget-glyph-directory'.
+`widget-glyph-directory'."
+(cond ((not (and image
-WARNING: If you call this with a glyph, and you want the user to be
+		   (string-match "XEmacs" emacs-version)
-able to activate the glyph, make sure it is unique.  If you use the
-same glyph for multiple widgets, activating any of the glyphs will
-cause the last created widget to be activated."
-(cond ((not (and (string-match "XEmacs" emacs-version)
 		   widget-glyph-enable
 		   (fboundp 'make-glyph)
 		   (fboundp 'locate-file)
 		   image))
 	 ;; We don't want or can't use glyphs.
-	 (insert tag))
+	 nil)
 	((and (fboundp 'glyphp)
 	      (glyphp image))
-	 ;; Already a glyph.  Insert it.
+	 ;; Already a glyph.  Use it.
-	 (widget-glyph-insert-glyph widget image))
+	 image)
 	((stringp image)
 	 ;; A string.  Look it up in relevant directories.
 	 (let* ((dirlist (list (or widget-glyph-directory
 				   (concat data-directory
 					   "custom/"))
 		(formats widget-image-conversion)
 		file)
 	   (while (and formats (not file))
 	     (when (valid-image-instantiator-format-p (car (car formats)))
 	       (setq file (locate-file image dirlist
-				       (mapconcat 'identity (cdr (car formats))
+				       (mapconcat 'identity
+						  (cdr (car formats))
 						  ":"))))
-	     (setq formats (cdr formats)))
+	     (unless file
-	   ;; We create a glyph with the file as the default image
+	       (setq formats (cdr formats))))
-	   ;; instantiator, and the TAG fallback
+	   (and file
-	   (widget-glyph-insert-glyph
+		;; We create a glyph with the file as the default image
-	    widget
+		;; instantiator, and the TAG fallback
-	    (make-glyph (if file
+		(make-glyph (list (vector (car (car formats)) ':file file)
-			    (list (vector (car (car formats)) ':file file)
+				  (vector 'string ':data tag))))))
-				  (vector 'string ':data tag))
-			  (vector 'string ':data tag))))))
 	((valid-instantiator-p image 'image)
-	 ;; A valid image instantiator (e.g. [gif ':file "somefile"] etc.)
+	 ;; A valid image instantiator (e.g. [gif :file "somefile"] etc.)
-	 (widget-glyph-insert-glyph widget
+	 (make-glyph (list image
-				    (list image
+			   (vector 'string ':data tag))))
-					  (vector 'string ':data tag))))
+	((consp image)
+	 ;; This could be virtually anything.  Let `make-glyph' sort it out.
+	 (make-glyph image))
 	(t
 	 ;; Oh well.
-	 (insert tag))))
+	 nil)))
+(defun widget-glyph-insert (widget tag image &optional down inactive)
+"In WIDGET, insert the text TAG or, if supported, IMAGE.
+IMAGE should either be a glyph, an image instantiator, or an image file
+name sans extension (xpm, xbm, gif, jpg, or png) located in
+`widget-glyph-directory'.
+Optional arguments DOWN and INACTIVE is used instead of IMAGE when the
+glyph is pressed or inactive, respectively.
+WARNING: If you call this with a glyph, and you want the user to be
+able to invoke the glyph, make sure it is unique.  If you use the
+same glyph for multiple widgets, invoking any of the glyphs will
+cause the last created widget to be invoked.
+Instead of an instantiator, you can also use a list of instantiators,
+or whatever `make-glyph' will accept.  However, in that case you must
+provide the fallback TAG as a part of the instantiator yourself."
+(let ((glyph (widget-glyph-find image tag)))
+(if glyph
+	(widget-glyph-insert-glyph widget
+				   glyph
+				   (widget-glyph-find down tag)
+				   (widget-glyph-find inactive tag))
+(insert tag))))
 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive)
-"In WIDGET, with alternative text TAG, insert GLYPH."
+"In WIDGET, insert GLYPH.
+If optional arguments DOWN and INACTIVE are given, they should be
+glyphs used when the widget is pushed and inactive, respectively."
 (set-glyph-property glyph 'widget widget)
 (when down
 (set-glyph-property down 'widget widget))
 (when inactive
 (set-glyph-property inactive 'widget widget))
 (insert "*")
-(add-text-properties (1- (point)) (point)
+(let ((ext (make-extent (point) (1- (point))))
-		       (list 'invisible t
+	(help-echo (widget-get widget :help-echo)))
-			     'end-glyph glyph))
+(set-extent-property ext 'invisible t)
+(set-extent-end-glyph ext glyph)
+(when help-echo
+(set-extent-property ext 'balloon-help help-echo)
+(set-extent-property ext 'help-echo help-echo)))
 (widget-put widget :glyph-up glyph)
 (when down (widget-put widget :glyph-down down))
-(when inactive (widget-put widget :glyph-inactive inactive))
+(when inactive (widget-put widget :glyph-inactive inactive)))
-(let ((help-echo (widget-get widget :help-echo)))
-(when help-echo
-(let ((extent (extent-at (1- (point)) nil 'end-glyph))
-	    (help-property (if (featurep 'balloon-help)
-			       'balloon-help
-			     'help-echo)))
-	(set-extent-property extent help-property (if (stringp help-echo)
-						      help-echo
-						    'widget-mouse-help))))))
 ;;; Buttons.
 (defgroup widget-button nil
 "The look of various kinds of buttons."
 :group 'widgets)
 (defcustom widget-button-prefix ""
 "String used as prefix for buttons."
 :type 'string
-:group 'widgets)
+:group 'widget-button)
 (defcustom widget-button-suffix ""
 "String used as suffix for buttons."
 :type 'string
-:group 'widgets)
+:group 'widget-button)
 (defun widget-button-insert-indirect (widget key)
 "Insert value of WIDGET's KEY property."
 (let ((val (widget-get widget key)))
 (while (and val (symbolp val))
 "Keymap containing useful binding for buffers containing widgets.
 Recommended as a parent keymap for modes using widgets.")
 (unless widget-keymap
 (setq widget-keymap (make-sparse-keymap))
-(define-key widget-keymap "\C-k" 'widget-kill-line)
 (define-key widget-keymap "\t" 'widget-forward)
-(define-key widget-keymap "\M-\t" 'widget-backward)
 (define-key widget-keymap [(shift tab)] 'widget-backward)
 (define-key widget-keymap [backtab] 'widget-backward)
 (if (string-match "XEmacs" emacs-version)
 (progn
 	;;Glyph support.
 (unless widget-field-keymap
 (setq widget-field-keymap (copy-keymap widget-keymap))
 (unless (string-match "XEmacs" (emacs-version))
 (define-key widget-field-keymap [menu-bar] 'nil))
+(define-key widget-field-keymap "\C-k" 'widget-kill-line)
+(define-key widget-field-keymap "\M-\t" 'widget-complete)
 (define-key widget-field-keymap "\C-m" 'widget-field-activate)
 (define-key widget-field-keymap "\C-a" 'widget-beginning-of-line)
 (define-key widget-field-keymap "\C-e" 'widget-end-of-line)
 (set-keymap-parent widget-field-keymap global-map))
 (define-key widget-text-keymap "\C-a" 'widget-beginning-of-line)
 (define-key widget-text-keymap "\C-e" 'widget-end-of-line)
 (set-keymap-parent widget-text-keymap global-map))
 (defun widget-field-activate (pos &optional event)
-"Activate the ediable field at point."
+"Invoke the ediable field at point."
 (interactive "@d")
-(let ((field (get-text-property pos 'field)))
+(let ((field (get-char-property pos 'field)))
 (if field
 	(widget-apply-action field event)
 (call-interactively
 (lookup-key widget-global-map (this-command-keys))))))
 (:bold t :underline t)))
 "Face used for pressed buttons."
 :group 'widgets)
 (defun widget-button-click (event)
-"Activate button below mouse pointer."
+"Invoke button below mouse pointer."
 (interactive "@e")
 (cond ((and (fboundp 'event-glyph)
 	      (event-glyph event))
 	 (widget-glyph-click event))
 	((widget-event-point event)
 	 (let* ((pos (widget-event-point event))
-		(button (get-text-property pos 'button)))
+		(button (get-char-property pos 'button)))
 	   (if button
-	       (let ((begin (previous-single-property-change (1+ pos) 'button))
+	       (let* ((overlay (widget-get button :button-overlay))
-		     (end (next-single-property-change pos 'button))
+		      (face (overlay-get overlay 'face))
-		     overlay)
+		      (mouse-face (overlay-get overlay 'mouse-face)))
 		 (unwind-protect
 		     (let ((track-mouse t))
-		       (setq overlay (make-overlay begin end))
+		       (overlay-put overlay
-		       (overlay-put overlay 'face 'widget-button-pressed-face)
+				    'face 'widget-button-pressed-face)
 		       (overlay-put overlay
 				    'mouse-face 'widget-button-pressed-face)
 		       (unless (widget-apply button :mouse-down-action event)
 			 (while (not (button-release-event-p event))
-			   (setq event (if (fboundp 'read-event)
+			   (setq event (widget-read-event)
-					   (read-event)
-					 (next-event))
 				 pos (widget-event-point event))
 			   (if (and pos
-				    (eq (get-text-property pos 'button)
+				    (eq (get-char-property pos 'button)
 					button))
 			       (progn
 				 (overlay-put overlay
 					      'face
 					      'widget-button-pressed-face)
 				 (overlay-put overlay
 					      'mouse-face
 					      'widget-button-pressed-face))
-			     (overlay-put overlay 'face nil)
+			     (overlay-put overlay 'face face)
-			     (overlay-put overlay 'mouse-face nil))))
+			     (overlay-put overlay 'mouse-face mouse-face))))
 		       (when (and pos
-				  (eq (get-text-property pos 'button) button))
+				  (eq (get-char-property pos 'button) button))
 			 (widget-apply-action button event)))
-		   (delete-overlay overlay)))
+		   (overlay-put overlay 'face face)
-	     (call-interactively
+		   (overlay-put overlay 'mouse-face mouse-face)))
-	      (or (lookup-key widget-global-map [ button2 ])
+	     (let (command up)
-		  (lookup-key widget-global-map [ down-mouse-2 ])
+	       ;; Find the global command to run, and check whether it
-		  (lookup-key widget-global-map [ mouse-2]))))))
+	       ;; is bound to an up event.
+	       (cond ((setq command	;down event
+			    (lookup-key widget-global-map [ button2 ])))
+		     ((setq command	;down event
+			    (lookup-key widget-global-map [ down-mouse-2 ])))
+		     ((setq command	;up event
+			    (lookup-key widget-global-map [ button2up ]))
+		      (setq up t))
+		     ((setq command	;up event
+			    (lookup-key widget-global-map [ mouse-2]))
+		      (setq up t)))
+	       (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)
-"Activate glyph below mouse pointer."
+"Invoke glyph below mouse pointer."
 (interactive "@e")
 (if (and (fboundp 'event-glyph)
 	   (event-glyph event))
 (widget-glyph-click event)
 (call-interactively (lookup-key widget-global-map (this-command-keys)))))
 	       (message "This glyph is inactive."))
 	      (t
 	       (widget-apply-action widget event)))))))
 (defun widget-button-press (pos &optional event)
-"Activate button at POS."
+"Invoke button at POS."
 (interactive "@d")
-(let ((button (get-text-property pos 'button)))
+(let ((button (get-char-property pos 'button)))
 (if button
 	(widget-apply-action button event)
 (let ((command (lookup-key widget-global-map (this-command-keys))))
 	(when (commandp command)
 	  (call-interactively command))))))
 (defun widget-move (arg)
 "Move point to the ARG next field or button.
 ARG may be negative to move backward."
-(while (> arg 0)
+(or (bobp) (> arg 0) (backward-char))
-(setq arg (1- arg))
+(let ((pos (point))
-(let ((next (cond ((get-text-property (point) 'button)
+	(number arg)
-		       (next-single-property-change (point) 'button))
+	(old (or (get-char-property (point) 'button)
-		      ((get-text-property (point) 'field)
+		 (get-char-property (point) 'field)))
-		       (next-single-property-change (point) 'field))
+	new)
-		      (t
+;; Forward.
-		       (point)))))
+(while (> arg 0)
-(if (null next)			; Widget extends to end. of buffer
+(if (eobp)
-	  (setq next (point-min)))
+	  (goto-char (point-min))
-(let ((button (next-single-property-change next 'button))
-	    (field (next-single-property-change next 'field)))
-	(cond ((or (get-text-property next 'button)
-		   (get-text-property next 'field))
-	       (goto-char next))
-	      ((and button field)
-	       (goto-char (min button field)))
-	      (button (goto-char button))
-	      (field (goto-char field))
-	      (t
-	       (let ((button (next-single-property-change (point-min) 'button))
-		     (field (next-single-property-change (point-min) 'field)))
-		 (cond ((and button field) (goto-char (min button field)))
-		       (button (goto-char button))
-		       (field (goto-char field))
-		       (t
-			(error "No buttons or fields found"))))))
-	(setq button (widget-at (point)))
-	(if (or (and button (widget-get button :tab-order)
-		     (< (widget-get button :tab-order) 0))
-		(and button (not (widget-apply button :active))))
-	    (setq arg (1+ arg))))))
-(while (< arg 0)
-(if (= (point-min) (point))
 	(forward-char 1))
-(setq arg (1+ arg))
+(and (eq pos (point))
-(let ((previous (cond ((get-text-property (1- (point)) 'button)
+	   (eq arg number)
-			   (previous-single-property-change (point) 'button))
+	   (error "No buttons or fields found"))
-			  ((get-text-property (1- (point)) 'field)
+(let ((new (or (get-char-property (point) 'button)
-			   (previous-single-property-change (point) 'field))
+		     (get-char-property (point) 'field))))
-			  (t
+	(when new
-			   (point)))))
+	  (unless (eq new old)
-(if (null previous)		; Widget extends to beg. of buffer
+	    (unless (and (widget-get new :tab-order)
-	  (setq previous (point-max)))
+			 (< (widget-get new :tab-order) 0))
-(let ((button (previous-single-property-change previous 'button))
+	      (setq arg (1- arg)))
-	    (field (previous-single-property-change previous 'field)))
+	    (setq old new)))))
-	(cond ((and button field)
+;; Backward.
-	       (goto-char (max button field)))
+(while (< arg 0)
-	      (button (goto-char button))
+(if (bobp)
-	      (field (goto-char field))
+	  (goto-char (point-max))
-	      (t
+	(backward-char 1))
-	       (let ((button (previous-single-property-change
+(and (eq pos (point))
-			      (point-max) 'button))
+	   (eq arg number)
-		     (field (previous-single-property-change
+	   (error "No buttons or fields found"))
-			     (point-max) 'field)))
+(let ((new (or (get-char-property (point) 'button)
-		 (cond ((and button field) (goto-char (max button field)))
+		     (get-char-property (point) 'field))))
-		       (button (goto-char button))
+	(when new
-		       (field (goto-char field))
+	  (unless (eq new old)
-		       (t
+	    (unless (and (widget-get new :tab-order)
-			(error "No buttons or fields found"))))))))
+			 (< (widget-get new :tab-order) 0))
-(let ((button (previous-single-property-change (point) 'button))
+	      (setq arg (1+ arg)))))))
-	  (field (previous-single-property-change (point) 'field)))
+(while  (or (get-char-property (point) 'button)
-(cond ((and button field)
+		(get-char-property (point) 'field))
-	     (goto-char (max button field)))
+(backward-char))
-	    (button (goto-char button))
+(forward-char))
-	    (field (goto-char field)))
-(setq button (widget-at (point)))
-(if (or (and button (widget-get button :tab-order)
-		   (< (widget-get button :tab-order) 0))
-	      (and button (not (widget-apply button :active))))
-	  (setq arg (1- arg)))))
 (widget-echo-help (point))
 (run-hooks 'widget-move-hook))
 (defun widget-forward (arg)
 "Move point to the next field or button.
 (widget-move (- arg)))
 (defun widget-beginning-of-line ()
 "Go to beginning of field or beginning of line, whichever is first."
 (interactive)
-(let ((bol (save-excursion (beginning-of-line) (point)))
+(let* ((field (widget-field-find (point)))
-	(prev (previous-single-property-change (point) 'field)))
+	 (start (and field (widget-field-start field))))
-(goto-char (max bol (or prev bol)))))
+(if (and start (not (eq start (point))))
+	(goto-char start)
+(call-interactively 'beginning-of-line))))
 (defun widget-end-of-line ()
 "Go to end of field or end of line, whichever is first."
 (interactive)
-(let ((bol (save-excursion (end-of-line) (point)))
+(let* ((field (widget-field-find (point)))
-	(prev (next-single-property-change (point) 'field)))
+	 (end (and field (widget-field-end field))))
-(goto-char (min bol (or prev bol)))))
+(if (and end (not (eq end (point))))
+	(goto-char end)
+(call-interactively 'end-of-line))))
 (defun widget-kill-line ()
 "Kill to end of field or end of line, whichever is first."
 (interactive)
-(let ((field (get-text-property (point) 'field))
+(let ((field (get-char-property (point) 'field))
-	(newline (save-excursion (search-forward "\n")))
+	(newline (save-excursion (forward-line 1)))
 	(next (next-single-property-change (point) 'field)))
 (if (and field (> newline next))
 	(kill-region (point) next)
 (call-interactively 'kill-line))))
+(defcustom widget-complete-field (lookup-key global-map "\M-\t")
+"Default function to call for completion inside fields."
+:options '(ispell-complete-word complete-tag lisp-complete-symbol)
+:type 'function
+:group 'widgets)
+(defun widget-complete ()
+"Complete content of editable field from point.
+When not inside a field, move to the previous button or field."
+(interactive)
+(let ((field (widget-field-find (point))))
+(if field
+	(widget-apply field :complete)
+(error "Not in an editable field"))))
 ;;; Setting up the buffer.
 (defvar widget-field-new nil)
 ;; List of all newly created editable fields in the buffer.
 	field)
 (while widget-field-new
 (setq field (car widget-field-new)
 	    widget-field-new (cdr widget-field-new)
 	    widget-field-list (cons field widget-field-list))
-(let ((from (widget-get field :value-from))
+(let ((from (car (widget-get field :field-overlay)))
-	    (to (widget-get field :value-to)))
+	    (to (cdr (widget-get field :field-overlay))))
 	(widget-specify-field field from to)
-	(move-marker from (1- from))
+	(set-marker from nil)
-	(move-marker to (1+ to)))))
+	(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)
-(if widget-field-list
+(if (and widget-field-list)
 (setq after-change-functions '(widget-after-change))
 (setq after-change-functions nil)))
 (defvar widget-field-last nil)
 ;; Last field containing point.
 (defvar widget-field-was nil)
 ;; The widget data before the change.
 (make-variable-buffer-local 'widget-field-was)
+(defun widget-field-buffer (widget)
+"Return the start of WIDGET's editing field."
+(overlay-buffer (widget-get widget :field-overlay)))
+(defun widget-field-start (widget)
+"Return the start of WIDGET's editing field."
+(overlay-start (widget-get widget :field-overlay)))
+(defun widget-field-end (widget)
+"Return the end of WIDGET's editing field."
+;; Don't subtract one if local-map works at the end of the overlay.
+(1- (overlay-end (widget-get widget :field-overlay))))
 (defun widget-field-find (pos)
-;; Find widget whose editing field is located at POS.
+"Return the field at POS.
-;; Return nil if POS is not inside and editing field.
+Unlike (get-char-property POS 'field) this, works with empty fields too."
-;;
-;; This is only used in `widget-field-modified', since ordinarily
-;; you would just test the field property.
 (let ((fields widget-field-list)
 	field found)
 (while fields
 (setq field (car fields)
 	    fields (cdr fields))
-(let ((from (widget-get field :value-from))
+(let ((start (widget-field-start field))
-	    (to (widget-get field :value-to)))
+	    (end (widget-field-end field)))
-	(if (and from to (< from pos) (> to  pos))
+	(when (and (<= start pos) (<= pos end))
-	    (setq fields nil
+	  (when found
-		  found field))))
+	    (debug "Overlapping fields"))
+	  (setq found field))))
 found))
 (defun widget-after-change (from to old)
 ;; Adjust field size and text properties.
 (condition-case nil
 (let ((field (widget-field-find from))
-	    (inhibit-read-only t))
+	    (other (widget-field-find to)))
-	(cond ((null field))
+	(when field
-	      ((not (eq field (widget-field-find to)))
+	  (unless (eq field other)
-	       (debug)
+	    (debug "Change in different fields"))
-	       (message "Error: `widget-after-change' called on two fields"))
+	  (let ((size (widget-get field :size)))
-	      (t
+	    (when size
-	       (let ((size (widget-get field :size)))
+	      (let ((begin (widget-field-start field))
-		 (if size
+		    (end (widget-field-end field)))
-		     (let ((begin (1+ (widget-get field :value-from)))
+		(cond ((< (- end begin) size)
-			   (end (1- (widget-get field :value-to))))
+		       ;; Field too small.
-		       (widget-specify-field-update field begin end)
+		       (save-excursion
-		       (cond ((< (- end begin) size)
+			 (goto-char end)
-			      ;; Field too small.
+			 (insert-char ?\  (- (+ begin size) end))))
-			      (save-excursion
+		      ((> (- end begin) size)
-				(goto-char end)
+		       ;; Field too large and
-				(insert-char ?\  (- (+ begin size) end))
+		       (if (or (< (point) (+ begin size))
-				(widget-specify-field-update field
+			       (> (point) end))
-							     begin
+			   ;; Point is outside extra space.
-							     (+ begin size))))
+			   (setq begin (+ begin size))
-			     ((> (- end begin) size)
+			 ;; Point is within the extra space.
-			      ;; Field too large and
+			 (setq begin (point)))
-			      (if (or (< (point) (+ begin size))
+		       (save-excursion
-				      (> (point) end))
+			 (goto-char end)
-				  ;; Point is outside extra space.
+			 (while (and (eq (preceding-char) ?\ )
-				  (setq begin (+ begin size))
+				     (> (point) begin))
-				;; Point is within the extra space.
+			   (delete-backward-char 1))))))))
-				(setq begin (point)))
+	  (widget-apply field :notify field)))
-			      (save-excursion
+(error (debug "After Change"))))
-				(goto-char end)
-				(while (and (eq (preceding-char) ?\ )
-					    (> (point) begin))
-				  (delete-backward-char 1))))))
-		   (widget-specify-field-update field from to)))
-	       (widget-apply field :notify field))))
-(error (debug))))
 ;;; Widget Functions
 ;;
 ;; These functions are used in the definition of multiple widgets.
 "Basic widget other widgets are derived from."
 :value-to-internal (lambda (widget value) value)
 :value-to-external (lambda (widget value) value)
 :button-prefix 'widget-button-prefix
 :button-suffix 'widget-button-suffix
+:complete 'widget-default-complete
 :create 'widget-default-create
 :indent nil
 :offset 0
 :format-handler 'widget-default-format-handler
 :button-face-get 'widget-default-button-face-get
 :deactivate 'widget-default-deactivate
 :mouse-down-action (lambda (widget event) nil)
 :action 'widget-default-action
 :notify 'widget-default-notify
 :prompt-value 'widget-default-prompt-value)
+(defun widget-default-complete (widget)
+"Call the value of the :complete-function property of WIDGET.
+If that does not exists, call the value of `widget-complete-field'."
+(let ((fun (widget-get widget :complete-function)))
+(call-interactively (or fun widget-complete-field))))
 (defun widget-default-create (widget)
 "Create WIDGET at point in the current buffer."
 (widget-specify-insert
 (let ((from (point))
 	     (when (eq (aref doc-text  0) ?*)
 	       (setq doc-text (substring doc-text 1)))
 	     ;; Get rid of trailing newlines.
 	     (when (string-match "\n+\\'" doc-text)
 	       (setq doc-text (substring doc-text 0 (match-beginning 0))))
-	     (push (if (string-match "\n." doc-text)
+	     (push (widget-create-child-and-convert
-		       ;; Allow multiline doc to be hiden.
+		    widget 'documentation-string
-		       (widget-create-child-and-convert
+		    doc-text)
-			widget 'widget-help
-			:doc (progn
-			       (string-match "\\`.*" doc-text)
-			       (match-string 0 doc-text))
-			:widget-doc doc-text
-			"?")
-		     ;; A single line is just inserted.
-		     (widget-create-child-and-convert
-		      widget 'item :format "%d" :doc doc-text nil))
 		   buttons)))
 	  (t
 	   (error "Unknown escape `%c'" escape)))
 (widget-put widget :buttons buttons)))
 (defun widget-default-delete (widget)
 ;; Remove widget from the buffer.
 (let ((from (widget-get widget :from))
 	(to (widget-get widget :to))
-	(inhibit-read-only t)
+	(inactive-overlay (widget-get widget :inactive))
-	after-change-functions)
+	(button-overlay (widget-get widget :button-overlay))
+	after-change-functions
+	(inhibit-read-only t))
 (widget-apply widget :value-delete)
+(when inactive-overlay
+(delete-overlay inactive-overlay))
+(when button-overlay
+(delete-overlay button-overlay))
 (when (< from to)
 ;; Kludge: this doesn't need to be true for empty formats.
 (delete-region from to))
 (set-marker from nil)
 (set-marker to nil))
 (defun widget-item-match-inline (widget values)
 ;; Match if the value is the same.
 (let ((value (widget-get widget :value)))
 (and (listp value)
 	 (<= (length value) (length values))
-	 (let ((head (subseq values 0 (length value))))
+	 (let ((head (widget-sublist values 0 (length value))))
 	   (and (equal head value)
-		(cons head (subseq values (length value))))))))
+		(cons head (widget-sublist values (length value))))))))
+(defun widget-sublist (list start &optional end)
+"Return the sublist of LIST from START to END.
+If END is omitted, it defaults to the length of LIST."
+(if (> start 0) (setq list (nthcdr start list)))
+(if end
+(if (<= end start)
+	  nil
+	(setq list (copy-sequence list))
+	(setcdr (nthcdr (- end start 1) list) nil)
+	list)
+(copy-sequence list)))
 (defun widget-item-action (widget &optional event)
 ;; Just notify itself.
 (widget-apply widget :notify widget event))
 "Apply :action for WIDGET."
 (widget-apply-action widget (this-command-keys)))
 ;;; The `link' Widget.
-(defcustom widget-link-prefix "_"
+(defcustom widget-link-prefix "["
 "String used as prefix for links."
 :type 'string
 :group 'widget-button)
-(defcustom widget-link-suffix "_"
+(defcustom widget-link-suffix "]"
 "String used as suffix for links."
 :type 'string
 :group 'widget-button)
 (define-widget 'link 'item
 (let ((prompt (concat (widget-apply widget :menu-tag-get) ": "))
 	  (value (unless invalid
 		   (widget-value widget))))
 (let ((answer (widget-apply widget :prompt-value prompt value invalid) ))
 	(widget-value-set widget answer)))
-(widget-apply widget :notify widget event)
+(widget-setup)
-(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))
 	  nil
 	widget))))
 (defun widget-field-value-create (widget)
 ;; Create an editable text field.
-(insert " ")
 (let ((size (widget-get widget :size))
 	(value (widget-get widget :value))
-	(from (point)))
+	(from (point))
+	(overlay (cons (make-marker) (make-marker))))
+(widget-put widget :field-overlay overlay)
 (insert value)
 (and size
 	 (< (length value) size)
 	 (insert-char ?\  (- size (length value))))
 (unless (memq widget widget-field-list)
 (setq widget-field-new (cons widget widget-field-new)))
-(widget-put widget :value-to (copy-marker (point)))
+(move-marker (cdr overlay) (point))
-(set-marker-insertion-type (widget-get widget :value-to) nil)
+(set-marker-insertion-type (cdr overlay) nil)
-(if (null size)
+(when (null size)
-	(insert ?\n)
+(insert ?\n))
-(insert ?\ ))
+(move-marker (car overlay) from)
-(widget-put widget :value-from (copy-marker from))
+(set-marker-insertion-type (car overlay) t)))
-(set-marker-insertion-type (widget-get widget :value-from) t)))
 (defun widget-field-value-delete (widget)
 ;; Remove the widget from the list of active editing fields.
 (setq widget-field-list (delq widget widget-field-list))
 ;; These are nil if the :format string doesn't contain `%v'.
-(when (widget-get widget :value-from)
+(let ((overlay (widget-get widget :field-overlay)))
-(set-marker (widget-get widget :value-from) nil))
+(when overlay
-(when (widget-get widget :value-from)
+(delete-overlay overlay))))
-(set-marker (widget-get widget :value-to) nil)))
 (defun widget-field-value-get (widget)
 ;; Return current text in editing field.
-(let ((from (widget-get widget :value-from))
+(let ((from (widget-field-start widget))
-	(to (widget-get widget :value-to))
+	(to (widget-field-end widget))
+	(buffer (widget-field-buffer widget))
 	(size (widget-get widget :size))
 	(secret (widget-get widget :secret))
 	(old (current-buffer)))
 (if (and from to)
 	(progn
-	  (set-buffer (marker-buffer from))
+	  (set-buffer buffer)
-	  (setq from (1+ from)
-		to (1- to))
 	  (while (and size
 		      (not (zerop size))
 		      (> to from)
 		      (eq (char-after (1- to)) ?\ ))
 	    (setq to (1- to)))
 	  (let ((result (buffer-substring-no-properties from to)))
-	    (when (string-match "XEmacs" emacs-version)
-	      ;; XEmacs 20.1 bug: b-s-n-p doesn't clear all properties.
-	      (setq result (format "%s" result)))
 	    (when secret
 	      (let ((index 0))
 		(while (< (+ from index) to)
 		  (aset result index
-			(get-text-property (+ from index) 'secret))
+			(get-char-property (+ from index) 'secret))
 		  (setq index (1+ index)))))
 	    (set-buffer old)
 	    result))
 (widget-get widget :value))))
 (widget-apply (car (widget-get widget :children)) :value-inline))
 (defcustom widget-choice-toggle nil
 "If non-nil, a binary choice will just toggle between the values.
 Otherwise, the user will explicitly have to choose between the values
-when he activate the menu."
+when he invoked the menu."
 :type 'boolean
 :group 'widgets)
 (defun widget-choice-mouse-down-action (widget &optional event)
 ;; Return non-nil if we need a menu.
 		 (widget-choose tag (reverse choices) event))))
 (when current
 (widget-value-set widget
 			(widget-apply current :value-to-external
 				      (widget-get current :value)))
-(widget-apply widget :notify widget event)
+(widget-setup)
-(widget-setup))))
+(widget-apply widget :notify widget event))))
 (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-put widget :children (cons child children))
 	  (while (not (eq (car (cdr children)) before))
 	    (setq children (cdr children)))
 	  (setcdr children (cons child (cdr children)))))))
 (widget-setup)
-widget (widget-apply widget :notify widget))
+(widget-apply widget :notify widget))
 (defun widget-editable-list-delete-at (widget child)
 ;; Delete child from list of children.
 (save-excursion
 (let ((buttons (copy-sequence (widget-get widget :buttons)))
 	      args nil)))
 (if answer
 	(cons found vals)
 nil)))
-;;; The `widget-help' Widget.
+;;; The `visibility' Widget.
-(define-widget 'widget-help 'push-button
+(define-widget 'visibility 'item
-"The widget documentation button."
+"An indicator and manipulator for hidden items."
-:format "%[%t%] %d"
+:format "%[%v%]"
-:help-echo "Toggle display of documentation."
+:button-prefix ""
-:action 'widget-help-action)
+:button-suffix ""
+:on "hide"
-(defun widget-help-action (widget &optional event)
+:off "show"
-"Toggle documentation for WIDGET."
+:value-create 'widget-visibility-value-create
-(let ((old (widget-get widget :doc))
+:action 'widget-toggle-action
-	(new (widget-get widget :widget-doc)))
+:match (lambda (widget value) t))
-(widget-put widget :doc new)
-(widget-put widget :widget-doc old))
+(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-glyph-insert widget on "down" "down-pushed")
+(widget-glyph-insert widget off "right" "right-pushed")
+(insert "..."))))
+;;; The `documentation-string' Widget.
+(defface widget-documentation-face '((((class color)
+				       (background dark))
+				      (:foreground "lime green"))
+				     (((class color)
+				       (background light))
+				      (:foreground "dark green"))
+				     (t nil))
+"Face used for documentation text."
+:group 'widgets)
+(define-widget 'documentation-string 'item
+"A documentation string."
+:format "%v"
+:action 'widget-documentation-string-action
+:value-delete 'widget-children-value-delete
+:value-create 'widget-documentation-string-value-create)
+(defun widget-documentation-string-value-create (widget)
+;; Insert documentation string.
+(let ((doc (widget-value widget))
+	(shown (widget-get (widget-get widget :parent) :documentation-shown)))
+(if (string-match "\n" doc)
+	(let ((before (substring doc 0 (match-beginning 0)))
+	      (after (substring doc (match-beginning 0)))
+	      (start (point))
+	      buttons)
+	  (insert before " ")
+	  (widget-specify-doc widget start (point))
+	  (push (widget-create-child-and-convert
+		 widget 'visibility
+		 :off nil
+		 :action 'widget-parent-action
+		 shown)
+		buttons)
+	  (when shown
+	    (setq start (point))
+	    (insert after)
+	    (widget-specify-doc widget start (point)))
+	  (widget-put widget :buttons buttons))
+(insert doc)))
+(insert "\n"))
+(defun widget-documentation-string-action (widget &rest ignore)
+;; Toggle documentation.
+(let ((parent (widget-get widget :parent)))
+(widget-put parent :documentation-shown
+		(not (widget-get parent :documentation-shown))))
+;; Redraw.
 (widget-value-set widget (widget-value widget)))
 ;;; The Sexp Widgets.
 (define-widget 'const 'item
 (define-widget 'string 'editable-field
 "A string"
 :tag "String"
 :format "%{%t%}: %v"
+:complete-function 'ispell-complete-word
 :prompt-history 'widget-string-prompt-value-history)
 (define-widget 'regexp 'string
 "A regular expression."
 :match 'widget-regexp-match
 (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 activated."
+It will read a file name from the minibuffer when invoked."
 :prompt-value 'widget-file-prompt-value
 :format "%{%t%}: %v"
 :tag "File"
 :action 'widget-file-action)
 	 (menu-tag (widget-apply widget :menu-tag-get))
 	 (must-match (widget-get widget :must-match))
 	 (answer (read-file-name (concat menu-tag ": (default `" value "') ")
 				 dir nil must-match file)))
 (widget-value-set widget (abbreviate-file-name answer))
-(widget-apply widget :notify widget event)
+(widget-setup)
-(widget-setup)))
+(widget-apply widget :notify widget event)))
 (define-widget 'directory 'file
 "A directory widget.
-It will read a directory name from the minibuffer when activated."
+It will read a directory name from the minibuffer when invoked."
 :tag "Directory")
 (defvar widget-symbol-prompt-value-history nil
 "History of input to `widget-symbol-prompt-value'.")
 (defvar widget-function-prompt-value-history nil
 "History of input to `widget-function-prompt-value'.")
 (define-widget 'function 'sexp
 "A lisp function."
+:complete-function 'lisp-complete-symbol
 :prompt-value 'widget-field-prompt-value
 :prompt-internal 'widget-symbol-prompt-internal
 :prompt-match 'fboundp
 :prompt-history 'widget-function-prompt-value-history
 :action 'widget-field-action
 :prompt-history 'widget-sexp-prompt-value-history
 :prompt-value 'widget-sexp-prompt-value)
 (defun widget-sexp-value-to-internal (widget value)
 ;; Use pp for printer representation.
-(let ((pp (pp-to-string value)))
+(let ((pp (if (symbolp value)
+		(prin1-to-string value)
+	      (pp-to-string value))))
 (while (string-match "\n\\'" pp)
 (setq pp (substring pp 0 -1)))
 (if (or (string-match "\n\\'" pp)
 	    (> (length pp) 40))
 	(concat "\n" pp)
 "A color name (with sample)."
 :format "%v (%{sample%})\n"
 :sample-face-get 'widget-color-item-button-face-get)
 (defun widget-color-item-button-face-get (widget)
-;; We create a face from the value.
+(let ((symbol (intern (concat "fg:" (widget-value widget)))))
-(require 'facemenu)
+(if (string-match "XEmacs" emacs-version)
-(condition-case nil
+	(prog1 symbol
-(facemenu-get-face (intern (concat "fg:" (widget-value widget))))
+	  (or (find-face symbol)
-(error 'default)))
+	      (set-face-foreground (make-face symbol) (widget-value widget))))
+(condition-case nil
+	  (facemenu-get-face symbol)
+	(error 'default)))))
 (define-widget 'color 'push-button
 "Choose a color name (with sample)."
 :format "%[%t%]: %v"
 :tag "Color"
 					 nil nil nil 'widget-color-history))
 		       (t
 			(read-string prompt (widget-value widget))))))
 (unless (zerop (length answer))
 (widget-value-set widget answer)
-(widget-apply widget :notify widget event)
+(widget-setup)
-(widget-setup))))
+(widget-apply widget :notify widget event))))
 ;;; The Help Echo
 (defun widget-echo-help-mouse ()
 "Display the help message for the widget under the mouse.
 (remove-hook 'post-command-hook 'widget-stop-mouse-tracking)
 (setq track-mouse nil))
 (defun widget-at (pos)
 "The button or field at POS."
-(or (get-text-property pos 'button)
+(or (get-char-property pos 'button)
-(get-text-property pos 'field)))
+(get-char-property pos 'field)))
 (defun widget-echo-help (pos)
 "Display the help echo for widget at POS."
 (let* ((widget (widget-at pos))
 	 (help-echo (and widget (widget-get widget :help-echo))))

Mercurial > hg > xemacs-beta

comparison lisp/custom/wid-edit.el @ 155:43dd3413c7c7 r20-3b4