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

comparison lisp/custom/wid-edit.el @ 116:9f59509498e1 r20-1b10

Import from CVS: tag r20-1b10

author	cvs
date	Mon, 13 Aug 2007 09:23:06 +0200
parents	c53a95d3c46d
children	7d55a9ba150c

comparison

equal deleted inserted replaced

-:f109f7dabbe2
+:9f59509498e1
 ;;
 ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
 ;;
 ;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
 ;; Keywords: extensions
-;; Version: 1.65
+;; Version: 1.68
 ;; X-URL: http://www.dina.kvl.dk/~abraham/custom/
 ;;; Commentary:
 ;;
 ;; See `widget.el'.
 (eval-and-compile
 (autoload 'pp-to-string "pp")
 (autoload 'Info-goto-node "info")
+(when (string-match "XEmacs" emacs-version)
+(require '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,
 (delete-region (point-min) (1+ (point-min)))
 (delete-region (1- (point-max)) (point-max))
 (goto-char (point-max))
 result)))
+(defface widget-inactive-face '((((class grayscale color)
+				  (background dark))
+				 (:foreground "light gray"))
+				(((class grayscale color)
+				  (background light))
+				 (:foreground "dark gray"))
+				(t
+				 (:italic t)))
+"Face used for inactive widgets."
+:group 'widgets)
+(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 'evaporate 't)
+(overlay-put overlay (if (string-match "XEmacs" emacs-version)
+			       'read-only
+			     'modification-hooks) '(widget-overlay-inactive))
+(widget-put widget :inactive overlay))))
+(defun widget-overlay-inactive (&rest junk)
+"Ignoring the arguments, signal an error."
+(unless inhibit-read-only
+(error "Attempt to modify inactive widget")))
+(defun widget-specify-active (widget)
+"Make WIDGET active for user modifications."
+(let ((inactive (widget-get widget :inactive)))
+(when inactive
+(delete-overlay inactive)
+(widget-put widget :inactive nil))))
 ;;; Widget Properties.
 (defsubst widget-type (widget)
 "Return the type of WIDGET, a symbol."
 (car widget))
 	((and vals
 	      (widget-apply widget :match (car vals)))
 	 (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)
+(widget-apply widget :action event)
+(error "Attempt to perform action on inactive widget")))
 ;;; Glyphs.
 (defcustom widget-glyph-directory (concat data-directory "custom/")
 "Where widget glyphs are located.
 If this variable is nil, widget will try to locate the directory
 (defun widget-field-activate (pos &optional event)
 "Activate the ediable field at point."
 (interactive "@d")
 (let ((field (get-text-property pos 'field)))
 (if field
-	(widget-apply field :action event)
+	(widget-apply-action field event)
 (call-interactively
 (lookup-key widget-global-map (this-command-keys))))))
 (defun widget-button-click (event)
 "Activate button below mouse pointer."
 (interactive "@e")
 (cond ((and (fboundp 'event-glyph)
 	      (event-glyph event))
 	 (let ((widget (glyph-property (event-glyph event) 'widget)))
 	   (if widget
-	       (widget-apply widget :action event)
+	       (widget-apply-action widget event)
 	     (message "You clicked on a glyph."))))
 	((event-point event)
 	 (let ((button (get-text-property (event-point event) 'button)))
 	   (if button
-	       (widget-apply button :action event)
+	       (widget-apply-action button event)
 	     (call-interactively
 	      (or (lookup-key widget-global-map [ button2 ])
 		  (lookup-key widget-global-map [ down-mouse-2 ])
 		  (lookup-key widget-global-map [ mouse-2]))))))
 	(t
 (interactive "@e")
 (if (and (fboundp 'event-glyph)
 	   (event-glyph event))
 (let ((widget (glyph-property (event-glyph event) 'widget)))
 	(if widget
-	    (widget-apply widget :action event)
+	    (widget-apply-action widget event)
 	  (message "You clicked on a glyph.")))
 (call-interactively (lookup-key widget-global-map (this-command-keys)))))
 (defun widget-button-press (pos &optional event)
 "Activate button at POS."
 (interactive "@d")
 (let ((button (get-text-property pos 'button)))
 (if button
-	(widget-apply button :action event)
+	(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)
 :delete 'widget-default-delete
 :value-set 'widget-default-value-set
 :value-inline 'widget-default-value-inline
 :menu-tag-get 'widget-default-menu-tag-get
 :validate (lambda (widget) nil)
+:active 'widget-default-active
+:activate 'widget-specify-active
+:deactivate 'widget-default-deactivate
 :action 'widget-default-action
 :notify 'widget-default-notify)
 (defun widget-default-create (widget)
 "Create WIDGET at point in the current buffer."
 (let ((from (widget-get widget :from))
 	(to (widget-get widget :to))
 	(inhibit-read-only t)
 	after-change-functions)
 (widget-apply widget :value-delete)
-(delete-region from to)
+(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-default-value-set (widget value)
 ;; Recreate widget with new value.
 (defun widget-default-menu-tag-get (widget)
 ;; Use tag or value for menus.
 (or (widget-get widget :menu-tag)
 (widget-get widget :tag)
 (widget-princ-to-string (widget-get widget :value))))
+(defun widget-default-active (widget)
+"Return t iff this widget active (user modifiable)."
+(and (not (widget-get widget :inactive))
+(let ((parent (widget-get widget :parent)))
+	 (or (null parent)
+	     (widget-apply parent :active)))))
+(defun widget-default-deactivate (widget)
+"Make WIDGET inactive for user modifications."
+(widget-specify-inactive widget
+			   (widget-get widget :from)
+			   (widget-get widget :to)))
 (defun widget-default-action (widget &optional event)
 ;; Notify the parent when a widget change
 (let ((parent (widget-get widget :parent)))
 (when parent
 				     (make-glyph (car (aref gui 1)))))
 (insert text))))
 (defun widget-gui-action (widget)
 "Apply :action for WIDGET."
-(widget-apply widget :action (this-command-keys)))
+(widget-apply-action widget (this-command-keys)))
 ;;; The `link' Widget.
 (define-widget 'link 'item
 "An embedded link."
 "A checkbox toggle."
 :format "%[%v%]"
 :on "[X]"
 :on-glyph "check1"
 :off "[ ]"
-:off-glyph "check0")
+:off-glyph "check0"
+:action 'widget-checkbox-action)
+(defun widget-checkbox-action (widget &optional event)
+"Toggle checkbox, notify parent, and set active state of sibling."
+(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)))))
 ;;; The `checklist' Widget.
 (define-widget 'checklist 'default
 "A multiple choice widget."
 				    :value (not (null chosen))
 				    button-args)))
 	       ((eq escape ?v)
 		(setq child
 		      (cond ((not chosen)
-			     (widget-create-child widget type))
+			     (let ((child (widget-create-child widget type)))
+			       (widget-apply child :deactivate)
+			       child))
 			    ((widget-get type :inline)
 			     (widget-create-child-value
 			      widget type (cdr chosen)))
 			    (t
 			     (widget-create-child-value
 				    button-args)))
 	       ((eq escape ?v)
 		(setq child (if chosen
 				(widget-create-child-value
 				 widget type value)
-			      (widget-create-child widget type))))
+			      (widget-create-child widget type)))
+		(unless chosen
+		  (widget-apply child :deactivate)))
 	       (t
 		(error "Unknown escape `%c'" escape)))))
 ;; Update properties.
 (when chosen
 (widget-put widget :choice type))
 (let* ((button (widget-get current :button))
 	     (match (and (not found)
 			 (widget-apply current :match value))))
 	(widget-value-set button match)
 	(if match
-	    (widget-value-set current value))
+	    (progn
+	      (widget-value-set current value)
+	      (widget-apply current :activate))
+	  (widget-apply current :deactivate))
 	(setq found (or found match))))))
 (defun widget-radio-validate (widget)
 ;; Valid if we have made a valid choice.
 (let ((children (widget-get widget :children))
 (while children
 	(setq current (car children)
 	      children (cdr children))
 	(let* ((button (widget-get current :button)))
 	  (cond ((eq child button)
-		 (widget-value-set button t))
+		 (widget-value-set button t)
+		 (widget-apply current :activate))
 		((widget-value button)
-		 (widget-value-set button nil)))))))
+		 (widget-value-set button nil)
+		 (widget-apply current :deactivate)))))))
 ;; Pass notification to parent.
 (widget-apply widget :notify child event))
 ;;; The `insert-button' Widget.
 	    (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-apply widget :notify widget))
+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-list (widget-get widget :buttons)))

Mercurial > hg > xemacs-beta

comparison lisp/custom/wid-edit.el @ 116:9f59509498e1 r20-1b10