[graphic-forms-cvs] r195 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Thu Jul 13 12:21:53 2006
New Revision: 195

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/button.lisp
   trunk/src/uitoolkit/widgets/item.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
   trunk/src/uitoolkit/widgets/widget.lisp
Log:
documented select/selected-p methods and implemented them for buttons

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Thu Jul 13 12:21:53 2006
@@ -1607,6 +1607,11 @@
 decorations are modified appropriately.
 @end deffn
 
+ at deffn GenericFunction select self flag
+Sets @var{self} to the selected state if @var{flag} is not @sc{nil}
+or to the unselected state if @sc{nil}.
+ at end deffn
+
 @deffn GenericFunction select-all self flag
 Sets the entire content of @code{self} to the selected state if
 @var{flag} is not @sc{nil} or to the unselected state if @sc{nil}.
@@ -1634,6 +1639,10 @@
 returns @sc{nil}.
 @end deffn
 
+ at deffn GenericFunction selected-p self => boolean
+Returns T if @var{self} is in the selected state; @sc{nil} otherwise.
+ at end deffn
+
 @anchor{show}
 @deffn GenericFunction show self flag
 Causes the object to be visible or hidden on the screen, but not

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Thu Jul 13 12:21:53 2006
@@ -112,7 +112,10 @@
                                 :dispatcher be
                                 :style (list subtype)))
          (setf (toggle-fn be) (create-button-toggler be))
-         (setf (gfw:text w) (funcall (toggle-fn be))))
+         (setf (gfw:text w) (funcall (toggle-fn be)))
+         (if (eql subtype :tri-state)
+           (gfw:check w t)
+           (gfw:check w t)))
       ((eql subtype :single-line-edit)
          (setf w (make-instance widget-class
                                 :parent *layout-tester-win*

Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp	(original)
+++ trunk/src/uitoolkit/widgets/button.lisp	Thu Jul 13 12:21:53 2006
@@ -40,6 +40,17 @@
 ;;; methods
 ;;;
 
+(defmethod check ((self button) flag)
+  (let ((bits (if flag gfs::+bst-checked+ gfs::+bst-unchecked+)))
+    (gfs::send-message (gfs:handle self) gfs::+bm-setcheck+ bits 0)))
+
+(defmethod checked-p ((self button))
+  (let ((bits (gfs::send-message (gfs:handle self) gfs::+bm-getcheck+ 0 0)))
+    (case bits
+      (gfs::+bst-checked+    t)
+      (gfs::+bst-unchecked+  nil)
+      (otherwise             nil))))
+
 (defmethod compute-style-flags ((self button) &rest extra-data)
   (declare (ignore extra-data))
   (let ((std-flags (logior +default-child-style+ gfs::+ws-tabstop+))
@@ -115,6 +126,12 @@
                                          (gfs:size-height text-size)))))
     size))
 
+(defmethod select ((self button) flag)
+  (check self flag))
+
+(defmethod selected-p ((self button))
+  (checked-p self))
+
 (defmethod text ((self button))
   (get-widget-text self))
 

Modified: trunk/src/uitoolkit/widgets/item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item.lisp	(original)
+++ trunk/src/uitoolkit/widgets/item.lisp	Thu Jul 13 12:21:53 2006
@@ -36,7 +36,12 @@
 (defun items-equal-p (item1 item2)
   (= (item-id item1) (item-id item2)))
 
-(defmethod check :before ((it item) flag)
+(defmethod check :before ((self item) flag)
   (declare (ignore flag))
-  (if (gfs:null-handle-p (gfs:handle it))
+  (if (gfs:null-handle-p (gfs:handle self))
+    (error 'gfs:toolkit-error :detail "null owner handle")))
+
+(defmethod checked-p :before ((self item))
+  (declare (ignore flag))
+  (if (gfs:null-handle-p (gfs:handle self))
     (error 'gfs:toolkit-error :detail "null owner handle")))

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Thu Jul 13 12:21:53 2006
@@ -297,6 +297,9 @@
 (defgeneric scroll (self dest-pnt src-rect children-too)
   (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))
 
+(defgeneric select (self flag)
+  (:documentation "Set self into (or out of) the selected state."))
+
 (defgeneric select-all (self flag)
   (:documentation "Set all items of this object into (or out of) the selected state."))
 

Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget.lisp	Thu Jul 13 12:21:53 2006
@@ -125,12 +125,16 @@
 (defmethod center-on-parent ((self widget))
   (center-object (parent self) self))
 
+(defmethod check :before ((self widget) flag)
+  (declare (ignore flag))
+  (if (gfs:disposed-p self)
+    (error 'gfs:disposed-error)))
+
 (defmethod checked-p :before ((self widget))
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
 (defmethod checked-p ((self widget))
-  (declare (ignore self))
   nil)
 
 (defmethod client-size :before ((self widget))