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

comparison lisp/custom/wid-edit.el @ 163:0132846995bd r20-3b8

Import from CVS: tag r20-3b8

author	cvs
date	Mon, 13 Aug 2007 09:43:35 +0200
parents	28f395d8dc7a
children	5a88923fcbfe

comparison

equal deleted inserted replaced

-:4de2936b4e77
+:0132846995bd
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.9916
+;; Version: 1.9931
 ;; 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
 (save-excursion
 (goto-char to)
 (when widget-field-add-space
 (insert-and-inherit " "))
 (setq to (point)))
-(add-text-properties (1- to) to ;to (1+ to)
+(if widget-field-add-space
-		       '(front-sticky nil start-open t read-only to))
+(add-text-properties (1- to) to
+			   '(front-sticky nil start-open t read-only to))
+(add-text-properties to (1+ to)
+			 '(front-sticky nil start-open t read-only to)))
 (add-text-properties (1- from) from
 		       '(rear-nonsticky t end-open t read-only from))
 (let ((map (widget-get widget :keymap))
 	(face (or (widget-get widget :value-face) 'widget-field-face))
 	(help-echo (widget-get widget :help-echo))
 ;; Execute FORM without inheriting any text properties.
 (`
 (save-restriction
 (let ((inhibit-read-only t)
 	   result
+	   before-change-functions
 	   after-change-functions)
 (insert "<>")
 (narrow-to-region (- (point) 2) (point))
 (widget-specify-none (point-min) (point-max))
 (goto-char (1+ (point-min)))
 (defface widget-inactive-face '((((class grayscale color)
 				  (background dark))
 				 (:foreground "light gray"))
 				(((class grayscale color)
 				  (background light))
-				 (:foreground "dark gray"))
+				 (:foreground "dim gray"))
 				(t
 				 (:italic t)))
 "Face used for inactive widgets."
 :group 'widget-faces)
 	     (setq widget (get tmp 'widget-type)))
 	    (t
 	     (setq missing nil))))
 value))
+(defun widget-get-indirect (widget property)
+"In WIDGET, get the value of PROPERTY.
+If the value is a symbol, return its binding.
+Otherwise, just return the value."
+(let ((value (widget-get widget property)))
+(if (symbolp value)
+	(symbol-value value)
+value)))
 (defun widget-member (widget property)
 "Non-nil iff there is a definition in WIDGET for PROPERTY."
 (cond ((widget-plist-member (cdr widget) property)
 	 t)
 	((car widget)
 	 (cons (list (car vals)) (cdr vals)))
 	(t nil)))
 (defun widget-apply-action (widget &optional event)
 "Apply :action in WIDGET in response to EVENT."
-(let (after-change-functions)
+(if (widget-apply widget :active)
-(if (widget-apply widget :active)
+(widget-apply widget :action event)
-	(widget-apply widget :action event)
+(error "Attempt to perform action on inactive widget")))
-(error "Attempt to perform action on inactive widget"))))
 ;;; Helper functions.
 ;;
 ;; These are widget specific.
 (defun widget-glyph-insert-glyph (widget glyph &optional down inactive)
 "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 widget
-(when down
+(set-glyph-property glyph 'widget widget)
-(set-glyph-property down 'widget widget))
+(when down
-(when inactive
+(set-glyph-property down 'widget widget))
-(set-glyph-property inactive 'widget widget))
+(when inactive
+(set-glyph-property inactive 'widget widget)))
 (insert "*")
 (let ((ext (make-extent (point) (1- (point))))
-	(help-echo (widget-get widget :help-echo)))
+	(help-echo (and widget (widget-get widget :help-echo))))
 (set-extent-property ext 'invisible t)
+(set-extent-property ext 'start-open t)
+(set-extent-property ext 'end-open 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 widget
-(when down (widget-put widget :glyph-down down))
+(widget-put widget :glyph-up glyph)
-(when inactive (widget-put widget :glyph-inactive inactive)))
+(when down (widget-put widget :glyph-down down))
+(when inactive (widget-put widget :glyph-inactive inactive))))
 ;;; Buttons.
 (defgroup widget-button nil
 "The look of various kinds of buttons."
 (defcustom widget-button-suffix ""
 "String used as suffix for buttons."
 :type 'string
 :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))
-(setq val (symbol-value val)))
-(when val
-(insert val))))
 ;;; Creating Widgets.
 ;;;###autoload
 (defun widget-create (type &rest args)
 widget))
 (defun widget-insert (&rest args)
 "Call `insert' with ARGS and make the text read only."
 (let ((inhibit-read-only t)
+	before-change-functions
 	after-change-functions
 	(from (point)))
 (apply 'insert args)
 (widget-specify-text from (point))))
 	(button (widget-get widget :button-overlay))
 	(field (widget-get widget :field-overlay))
 	(children (widget-get widget :children)))
 (set-marker from nil)
 (set-marker to nil)
-(delete-overlay button)
+(when button
-(delete-overlay field)
+(delete-overlay button))
+(when field
+(delete-overlay field))
 (mapcar 'widget-leave-text children)))
 ;;; Keymap and Commands.
 (defvar widget-keymap nil
 (defun widget-setup ()
 "Setup current buffer so editing string widgets works."
 (let ((inhibit-read-only t)
 	(after-change-functions nil)
+	before-change-functions
 	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))
 	(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)
-(if (and widget-field-list)
+(make-local-variable 'before-change-functions)
-(setq after-change-functions '(widget-after-change))
+(setq after-change-functions
-(setq after-change-functions nil)))
+	(if widget-field-list '(widget-after-change) nil))
+(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)
 	(when (and (<= start pos) (<= pos end))
 	  (when found
 	    (debug "Overlapping fields"))
 	  (setq found field))))
 found))
+(defun widget-before-change (from &rest ignore)
+;; This is how, for example, a variable changes its state to `modified'.
+;; when it is being edited.
+(condition-case nil
+(let ((field (widget-field-find from)))
+	(widget-apply field :notify field))
+(error (debug "Before Change"))))
 (defun widget-after-change (from to old)
 ;; Adjust field size and text properties.
 (condition-case nil
 (let ((field (widget-field-find from))
 	 (replace-match "" t t)
 	 (cond ((eq escape ?%)
 		(insert "%"))
 	       ((eq escape ?\[)
 		(setq button-begin (point))
-		(widget-button-insert-indirect widget :button-prefix))
+		(insert (widget-get-indirect widget :button-prefix)))
 	       ((eq escape ?\])
-		(widget-button-insert-indirect widget :button-suffix)
+		(insert (widget-get-indirect widget :button-suffix))
 		(setq button-end (point)))
 	       ((eq escape ?\{)
 		(setq sample-begin (point)))
 	       ((eq escape ?\})
 		(setq sample-end (point)))
 				 (t
 				  (funcall doc-property
 					   (widget-get widget :value)))))
 		  (doc-text (and (stringp doc-try)
 				 (> (length doc-try) 1)
-				 doc-try)))
+				 doc-try))
+		  (doc-indent (widget-get widget :documentation-indent)))
 	     (when doc-text
 	       (and (eq (preceding-char) ?\n)
 		    (widget-get widget :indent)
 		    (insert-char ?  (widget-get widget :indent)))
 	       ;; The `*' in the beginning is redundant.
 	       ;; Get rid of trailing newlines.
 	       (when (string-match "\n+\\'" doc-text)
 		 (setq doc-text (substring doc-text 0 (match-beginning 0))))
 	       (push (widget-create-child-and-convert
 		      widget 'documentation-string
+		      :indent (cond ((numberp doc-indent )
+				     doc-indent)
+				    ((null doc-indent)
+				     nil)
+				    (t 0))
 		      doc-text)
 		     buttons))))
 	  (t
 	   (error "Unknown escape `%c'" escape)))
 (widget-put widget :buttons buttons)))
 ;; Remove widget from the buffer.
 (let ((from (widget-get widget :from))
 	(to (widget-get widget :to))
 	(inactive-overlay (widget-get widget :inactive))
 	(button-overlay (widget-get widget :button-overlay))
+	before-change-functions
 	after-change-functions
 	(inhibit-read-only t))
 (widget-apply widget :value-delete)
 (when inactive-overlay
 (delete-overlay inactive-overlay))
 (defun widget-push-button-value-create (widget)
 ;; Insert text representing the `on' and `off' states.
 (let* ((tag (or (widget-get widget :tag)
 		  (widget-get widget :value)))
+	 (tag-glyph (widget-get widget :tag-glyph))
 	 (text (concat widget-push-button-prefix
 		       tag widget-push-button-suffix))
 	 (gui (cdr (assoc tag widget-push-button-cache))))
-(if (and (fboundp 'make-gui-button)
+(cond (tag-glyph
+	   (widget-glyph-insert widget text tag-glyph))
+	  ((and (fboundp 'make-gui-button)
 	     (fboundp 'make-glyph)
 	     widget-push-button-gui
 	     (fboundp 'device-on-window-system-p)
 	     (device-on-window-system-p)
 	     (string-match "XEmacs" emacs-version))
-	(progn
+	   (unless gui
-	  (unless gui
+	     (setq gui (make-gui-button tag 'widget-gui-action widget))
-	    (setq gui (make-gui-button tag 'widget-gui-action widget))
+	     (push (cons tag gui) widget-push-button-cache))
-	    (push (cons tag gui) widget-push-button-cache))
+	   (widget-glyph-insert-glyph widget
-	  (widget-glyph-insert-glyph widget
+				      (make-glyph
-				     (make-glyph
+				       (list (nth 0 (aref gui 1))
-				      (list (nth 0 (aref gui 1))
+					     (vector 'string ':data text)))
-					    (vector 'string ':data text)))
+				      (make-glyph
-				     (make-glyph
+				       (list (nth 1 (aref gui 1))
-				      (list (nth 1 (aref gui 1))
+					     (vector 'string ':data text)))
-					    (vector 'string ':data text)))
+				      (make-glyph
-				     (make-glyph
+				       (list (nth 2 (aref gui 1))
-				      (list (nth 2 (aref gui 1))
+					     (vector 'string ':data text)))))
-					    (vector 'string ':data text)))))
+	  (t
-(insert text))))
+	   (insert text)))))
 (defun widget-gui-action (widget)
 "Apply :action for WIDGET."
 (widget-apply-action widget (this-command-keys)))
 (defun widget-editable-list-insert-before (widget before)
 ;; Insert a new child in the list of children.
 (save-excursion
 (let ((children (widget-get widget :children))
 	  (inhibit-read-only t)
+	  before-change-functions
 	  after-change-functions)
 (cond (before
 	     (goto-char (widget-get before :entry-from)))
 	    (t
 	     (goto-char (widget-get widget :value-pos))))
 ;; Delete child from list of children.
 (save-excursion
 (let ((buttons (copy-sequence (widget-get widget :buttons)))
 	  button
 	  (inhibit-read-only t)
+	  before-change-functions
 	  after-change-functions)
 (while buttons
 	(setq button (car buttons)
 	      buttons (cdr buttons))
 	(when (eq (widget-get button :widget) child)
 		      :buttons (delq button (widget-get widget :buttons)))
 	  (widget-delete button))))
 (let ((entry-from (widget-get child :entry-from))
 	  (entry-to (widget-get child :entry-to))
 	  (inhibit-read-only t)
+	  before-change-functions
 	  after-change-functions)
 (widget-delete child)
 (delete-region entry-from entry-to)
 (set-marker entry-from nil)
 (set-marker entry-to nil))
 (define-widget 'visibility 'item
 "An indicator and manipulator for hidden items."
 :format "%[%v%]"
 :button-prefix ""
 :button-suffix ""
-:on "hide"
+:on "Hide"
-:off "show"
+:off "Show"
 :value-create 'widget-visibility-value-create
 :action 'widget-toggle-action
 :match (lambda (widget value) t))
 (defun widget-visibility-value-create (widget)
 			 on
 			 widget-push-button-suffix))
 (setq on ""))
 (if off
 	(setq off (concat widget-push-button-prefix
-			 off
+			  off
-			 widget-push-button-suffix))
+			  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")
+(widget-glyph-insert widget off "right" "right-pushed"))))
-(insert "..."))))
 ;;; The `documentation-link' Widget.
+;;
+;; This is a helper widget for `documentation-string'.
 (define-widget 'documentation-link 'link
 "Link type used in documentation strings."
+:tab-order -1
+:help-echo 'widget-documentation-link-echo-help
 :action 'widget-documentation-link-action)
+(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."
 (apropos (concat "\\`" (regexp-quote (widget-get widget :value)) "\\'")))
 (let ((regexp widget-documentation-link-regexp)
 	  (predicate widget-documentation-link-p)
 	  (type widget-documentation-link-type)
 	  (buttons (widget-get widget :buttons)))
 (save-excursion
-	(goto-char (point-min))
+	(goto-char from)
 	(while (re-search-forward regexp to t)
 	  (let ((name (match-string 1))
-		(begin (match-beginning 0))
+		(begin (match-beginning 1))
-		(end (match-end 0)))
+		(end (match-end 1)))
 	    (when (funcall predicate name)
 	      (push (widget-convert-button type begin end :value name)
 		    buttons)))))
-(widget-put widget :buttons buttons))))
+(widget-put widget :buttons buttons)))
+(let ((indent (widget-get widget :indent)))
+(when (and indent (not (zerop indent)))
+(save-excursion
+	(save-restriction
+	  (narrow-to-region from to)
+	  (goto-char (point-min))
+	  (while (search-forward "\n" nil t)
+	    (insert-char ?\  indent)))))))
 ;;; The `documentation-string' Widget.
 (define-widget 'documentation-string 'item
 "A documentation string."
 :value-create 'widget-documentation-string-value-create)
 (defun widget-documentation-string-value-create (widget)
 ;; Insert documentation string.
 (let ((doc (widget-value widget))
+	(indent (widget-get widget :indent))
 	(shown (widget-get (widget-get widget :parent) :documentation-shown))
 	(start (point)))
 (if (string-match "\n" doc)
 	(let ((before (substring doc 0 (match-beginning 0)))
 	      (after (substring doc (match-beginning 0)))
 	      buttons)
 	  (insert before " ")
 	  (widget-documentation-link-add widget start (point))
 	  (push (widget-create-child-and-convert
 		 widget 'visibility
-		 :off nil
+		 :help-echo "Show or hide rest of the documentation."
+		 :off "More"
 		 :action 'widget-parent-action
 		 shown)
 		buttons)
 	  (when shown
 	    (setq start (point))
+	    (when (and indent (not (zerop indent)))
+	      (insert-char ?\  indent))
 	    (insert after)
 	    (widget-documentation-link-add widget start (point)))
 	  (widget-put widget :buttons buttons))
 (insert doc)
 (widget-documentation-link-add widget start (point))))
 			   (widget-apply widget :value-to-internal value))))
 (define-widget 'choice 'menu-choice
 "A union of several sexp types."
 :tag "Choice"
-:format "%[%t%]: %v"
+:format "%{%t%}: %[Value Menu%] %v"
+:button-prefix 'widget-push-button-prefix
+:button-suffix 'widget-push-button-suffix
 :prompt-value 'widget-choice-prompt-value)
 (defun widget-choice-prompt-value (widget prompt value unbound)
 "Make a choice."
 (let ((args (widget-get widget :args))
 (define-widget 'boolean 'toggle
 "To be nil or non-nil, that is the question."
 :tag "Boolean"
 :prompt-value 'widget-boolean-prompt-value
-:format "%[%t%]: %v\n")
+:button-prefix 'widget-push-button-prefix
+:button-suffix 'widget-push-button-suffix
+:format "%{%t%}: %[Toggle%]  %v\n"
+:on "on (non-nil)"
+:off "off (nil)")
 (defun widget-boolean-prompt-value (widget prompt value unbound)
 ;; Toggle a boolean.
 (y-or-n-p prompt))

Mercurial > hg > xemacs-beta

comparison lisp/custom/wid-edit.el @ 163:0132846995bd r20-3b8