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 +@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}. +@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 +@deffn GenericFunction selected-p self => boolean +Returns T if @var{self} is in the selected state; @sc{nil} otherwise. +@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))