[graphic-forms-cvs] r254 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun Sep 10 21:31:02 UTC 2006
Author: junrue
Date: Sun Sep 10 17:31:01 2006
New Revision: 254
Modified:
trunk/docs/manual/widget-functions.texinfo
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/widget-tester.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/item-manager.lisp
trunk/src/uitoolkit/widgets/list-box.lisp
trunk/src/uitoolkit/widgets/list-item.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/widget.lisp
Log:
fixed a bug in checked-p for buttons; implemented low-level select and deselect functions for list-box; enhanced test-native-style to support more than one bit to test
Modified: trunk/docs/manual/widget-functions.texinfo
==============================================================================
--- trunk/docs/manual/widget-functions.texinfo (original)
+++ trunk/docs/manual/widget-functions.texinfo Sun Sep 10 17:31:01 2006
@@ -16,22 +16,35 @@
@anchor{append-item}
@deffn GenericFunction append-item self thing dispatcher &optional disabled checked => @ref{item}
-Adds a new item representing @var{thing} to @var{self}, where the
-class of @var{self} must derive from @ref{item-manager}. The
-newly-created item is returned. The @var{dispatcher} parameter must
-be an instance of @ref{event-dispatcher} or a subclass thereof. The
-optional @var{checked} and @var{disabled} arguments can be used to set
-the item's initial state.
+Adds a new item representing @var{thing} to @var{self}, where @var{thing}
+can be any @sc{object}. The newly-created item is returned.
+The @var{dispatcher} parameter must be one of the following:
+ at itemize @bullet
+ at item An instance of @ref{event-dispatcher} or a subclass thereof.
+ at item A function whose argument list matches the event method
+identified by the @var{callback-event-name} slot in @var{self}'s
+class.
+
+See also @ref{items-of}.
+ at end itemize
+
+The optional @var{checked} and @var{disabled} arguments will each be
+interpreted as @sc{generalized boolean} values in order to set the
+item's initial state. Note, however, that not all @ref{item-manager}
+subclasses support enabled or checked states for individual items.
@end deffn
@deffn GenericFunction append-separator self => @ref{item}
-Adds a separator item to @var{self}, and returns the newly-created item.
+Adds a separator to @var{self}, and returns a newly-created item to
+wrap the separator. A separator is a thin etched divider that serves
+to visually separate groups of items and has no other behavior.
@end deffn
- at deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{item}
+ at deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked => @ref{menu-item}
Adds @var{submenu} anchored to @var{self} and returns the corresponding
- at ref{menu-item}. The optional @var{checked} and @var{disabled} arguments can
-be used to set the menu item's initial state.
+menu-item. The optional @var{checked} and @var{disabled} arguments
+will each be interpreted as @sc{generalized boolean} values
+in order to set the menu item's initial state.
@end deffn
@anchor{auto-hscroll-p}
@@ -139,6 +152,16 @@
presses @sc{enter}.
@end deffn
+ at anchor{data-of}
+ at deffn Accessor data-of self
+(setf (@strong{data-of} @var{self}) @var{object})@*
+
+Returns application-specific data associated with @var{self}.
+
+The corresponding @sc{set} function associates new data with
+ at var{self}.
+ at end deffn
+
@deffn GenericFunction delete-all self
Removes all content from @var{self}.
@end deffn
@@ -259,8 +282,33 @@
an image or an icon-bundle.
@end deffn
+ at anchor{item-count}
+ at deffn GenericFunction item-count self => integer
+Returns the number of instances of @ref{item} subclasses contained within
+ at var{self}.
+ at end deffn
+
+ at anchor{item-index}
@deffn GenericFunction item-index self item
-Return the zero-based index of the location of the other object in this object.
+Return the zero-based index of the location of @var{item} within @var{self}.
+ at end deffn
+
+ at anchor{items-of}
+ at deffn GenericFunction items-of self
+(setf (@strong{items-of} @var{self}) @var{items})@*
+
+Returns a fresh @sc{list} of @ref{item} subclasses appropriate for
+ at var{self}'s type.
+
+The corresponding @sc{setf} function accepts a list whose contents
+are any combination of:
+ at itemize @bullet
+ at item Instances of @ref{item} subclasses appropriate for @var{self}.
+ at item Instances of any @sc{object} type; these will be wrapped by item
+objects, to be accessible later via the @ref{data-of} method.
+ at end itemize
+Existing items contained by @var{self} are replaced, and then the
+native control is refreshed. See also @ref{append-item}.
@end deffn
@anchor{layout}
@@ -284,7 +332,10 @@
Calls @var{func}, which is a function of two arguments, for each
child of @var{self} and places @var{func}'s return value in
@var{result-list}. @var{func}'s two arguments are @var{self} and
-the current child.
+the current child. Note that @code{mapchildren} accesses @var{self}'s
+ at emph{actual} children as determined by the underlying window's
+data structures, regardless of any @ref{layout-manager} assigned
+to @var{self}.
@end deffn
@anchor{maximum-size}
@@ -464,16 +515,18 @@
@deffn GenericFunction selected-items self => list
(setf (@strong{selected-items} @var{self}) @var{list})
-Returns a @sc{list} containing subclasses of @ref{item} appropriate
-for @var{self} that correspond to selections made by the user, or
- at sc{nil} if there are no selections. This function is defined only
-for @ref{widget}s whose notion of @emph{selection} is a set of
-item objects.
-
-The @sc{setf} function takes a @var{list} of item subclasses
-appropriate for @var{self} which identify the items in
- at var{self} that should be selected. Passing @sc{nil} will unselect all
-items, which is equivalent to calling @ref{select-all} with @sc{nil}.
+Returns a fresh @sc{list} containing subclasses of @ref{item}
+appropriate for @var{self} that correspond to selections made by the
+user, or @sc{nil} if there are no selections. This function is defined
+only for @ref{widget}s whose notion of @emph{selection} is a set of
+instances of @ref{item} subclasses.
+
+The @sc{setf} function takes a @sc{list} of instances of item
+subclasses appropriate for @var{self} which identify the items in
+ at var{self} that should be selected. at footnote{In this respect,
+ at ref{selected-items} is not symmetric with @ref{items-of}.} Passing
+ at sc{nil} will unselect all items, which is equivalent to calling
+ at ref{select-all} with @sc{nil}.
@end deffn
@anchor{selected-p}
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Sun Sep 10 17:31:01 2006
@@ -436,6 +436,7 @@
#:initial-delay-of
#:horizontal-scrollbar
#:image
+ #:item-count
#:item-height
#:item-id
#:item-index
Modified: trunk/src/tests/uitoolkit/widget-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/widget-tester.lisp (original)
+++ trunk/src/tests/uitoolkit/widget-tester.lisp Sun Sep 10 17:31:01 2006
@@ -65,10 +65,12 @@
(gfg:foreground-color gc) color))
(gfg:draw-filled-rectangle gc (gfs:make-rectangle :size (gfw:client-size window))))
-(defun manage-lb-button-states (lb move-btn all-btn none-btn)
+(defun manage-lb-button-states (lb move-btn selected-btn all-btn none-btn)
(let ((sel-count (gfw:selected-count lb))
- (item-count (length (gfw:items-of lb))))
+ (item-count (gfw:item-count lb)))
(gfw:enable move-btn (> sel-count 0))
+ (if selected-btn
+ (gfw:check selected-btn (> sel-count 0)))
(if all-btn
(gfw:enable all-btn (and (> item-count 0) (< sel-count item-count))))
(if none-btn
@@ -80,39 +82,64 @@
(if sel-items
(setf (gfw:items-of dest-lb) (append sel-items (gfw:items-of dest-lb))))))
+(defun select-lb-content (lb state)
+ (let ((count (gfw:item-count lb))
+ (func (if state #'gfw::lb-select-item #'gfw::lb-deselect-item)))
+ (loop for index in '(0 2 4)
+ when (>= count (1+ index))
+ do (funcall func lb index))))
+#|
+ (let ((items (gfw:items-of lb)))
+ (setf (gfw:selected-items lb) (subseq items 0 (min 4 (length items))))))
+|#
+
(defun populate-list-box-test-panel ()
(setf (gfw:text *widget-tester-win*) "Widget Tester (List Boxes)")
(let* ((panel-disp (make-instance 'widget-tester-panel-events))
- (lb1 nil)
- (lb2 nil)
- (btn-left nil)
- (btn-right nil)
- (btn-all nil)
- (btn-none nil)
- (lb1-callback (lambda (disp lb)
- (declare (ignore disp))
- (manage-lb-button-states lb btn-right btn-all btn-none)))
- (lb2-callback (lambda (disp lb)
- (declare (ignore disp))
- (manage-lb-button-states lb btn-left nil nil)))
- (btn-left-callback (lambda (disp btn)
- (declare (ignore disp btn))
- (move-lb-content lb2 lb1)
- (manage-lb-button-states lb1 btn-right btn-all btn-none)
- (manage-lb-button-states lb2 btn-left nil nil)))
- (btn-right-callback (lambda (disp btn)
- (declare (ignore disp btn))
- (move-lb-content lb1 lb2)
- (manage-lb-button-states lb1 btn-right btn-all btn-none)
- (manage-lb-button-states lb2 btn-left nil nil)))
- (btn-all-callback (lambda (disp btn)
- (declare (ignore disp btn))
- (gfw:select-all lb1 t)
- (manage-lb-button-states lb1 btn-right btn-all btn-none)))
- (btn-none-callback (lambda (disp btn)
- (declare (ignore disp btn))
- (gfw:select-all lb1 nil)
- (manage-lb-button-states lb1 btn-right btn-all btn-none)))
+ (latch nil)
+ (lb1 nil)
+ (lb2 nil)
+ (btn-left nil)
+ (btn-right nil)
+ (btn-all nil)
+ (btn-none nil)
+ (btn-select nil)
+ (lb1-callback (lambda (disp lb)
+ (declare (ignore disp))
+ (manage-lb-button-states lb btn-right (if latch nil btn-select) btn-all btn-none)))
+ (lb2-callback (lambda (disp lb)
+ (declare (ignore disp))
+ (manage-lb-button-states lb btn-left nil nil nil)))
+ (btn-left-callback (lambda (disp btn)
+ (declare (ignore disp btn))
+ (move-lb-content lb2 lb1)
+ (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none)
+ (manage-lb-button-states lb2 btn-left nil nil nil)))
+ (btn-right-callback (lambda (disp btn)
+ (declare (ignore disp btn))
+ (move-lb-content lb1 lb2)
+ (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none)
+ (manage-lb-button-states lb2 btn-left nil nil nil)))
+ (btn-all-callback (lambda (disp btn)
+ (declare (ignore disp btn))
+ (gfw:select-all lb1 t)
+ (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none)))
+ (btn-none-callback (lambda (disp btn)
+ (declare (ignore disp btn))
+ (gfw:select-all lb1 nil)
+ (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none)))
+ (btn-reset-callback (lambda (disp btn)
+ (declare (ignore disp btn))
+ (gfw:delete-all lb2)
+ (setf (gfw:items-of lb1) *list-box-test-data*)
+ (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none)
+ (manage-lb-button-states lb2 btn-left nil nil nil)))
+ (btn-select-callback (lambda (disp btn)
+ (declare (ignore disp))
+ (setf latch t)
+ (select-lb-content lb1 (gfw:selected-p btn))
+ (manage-lb-button-states lb1 btn-right nil btn-all btn-none)
+ (setf latch nil)))
(outer-panel (make-instance 'gfw:panel :dispatcher panel-disp
:parent *widget-tester-win*
@@ -135,21 +162,28 @@
:items (subseq *list-box-test-data* 4)))
(gfw:pack lb1-panel)
- (setf btn-right (make-instance 'gfw:button :parent btn-panel
- :text " ==> "
- :callback btn-right-callback))
+ (setf btn-right (make-instance 'gfw:button :parent btn-panel
+ :text " ==> "
+ :callback btn-right-callback))
(gfw:enable btn-right nil)
- (setf btn-left (make-instance 'gfw:button :parent btn-panel
- :text " <== "
- :callback btn-left-callback))
+ (setf btn-left (make-instance 'gfw:button :parent btn-panel
+ :text " <== "
+ :callback btn-left-callback))
(gfw:enable btn-left nil)
- (setf btn-all (make-instance 'gfw:button :parent btn-panel
- :text "Select All"
- :callback btn-all-callback))
- (setf btn-none (make-instance 'gfw:button :parent btn-panel
- :text "Select None"
- :callback btn-none-callback))
+ (setf btn-all (make-instance 'gfw:button :parent btn-panel
+ :text "Select All"
+ :callback btn-all-callback))
+ (setf btn-none (make-instance 'gfw:button :parent btn-panel
+ :text "Select None"
+ :callback btn-none-callback))
(gfw:enable btn-none nil)
+ (make-instance 'gfw:button :parent btn-panel
+ :text "Reset"
+ :callback btn-reset-callback)
+ (setf btn-select (make-instance 'gfw:button :parent btn-panel
+ :text "Select 0,2,4"
+ :style '(:check-box)
+ :callback btn-select-callback))
(gfw:pack btn-panel)
(make-instance 'gfw:label :text "Extended Select:" :parent lb2-panel)
@@ -160,12 +194,17 @@
(gfw:pack lb2-panel)
(gfw:pack outer-panel)
+ ;; FIXME: need to think of a more elegant solution for the following
+ ;; use-case where we want synchronize the sizes of two or more
+ ;; layout children
+ ;;
(let ((size (gfw:size lb1)))
(setf (gfw:maximum-size lb1) size
(gfw:minimum-size lb1) size
(gfw:maximum-size lb2) size
(gfw:minimum-size lb2) size))
(setf (gfw:items-of lb1) *list-box-test-data*)
+ (manage-lb-button-states lb1 btn-right btn-select btn-all btn-none)
(gfw:delete-all lb2)
outer-panel))
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Sun Sep 10 17:31:01 2006
@@ -729,3 +729,9 @@
("UpdateWindow" update-window)
BOOL
(hwnd HANDLE))
+
+(defcfun
+ ("ValidateRect" validate-rect)
+ BOOL
+ (hwnd HANDLE)
+ (rct LPTR))
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Sun Sep 10 17:31:01 2006
@@ -46,10 +46,7 @@
(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))))
+ (= (logand bits gfs::+bst-checked+) gfs::+bst-checked+)))
(defmethod compute-style-flags ((self button) &rest extra-data)
(declare (ignore extra-data))
Modified: trunk/src/uitoolkit/widgets/item-manager.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item-manager.lisp (original)
+++ trunk/src/uitoolkit/widgets/item-manager.lisp Sun Sep 10 17:31:01 2006
@@ -124,6 +124,13 @@
(dotimes (i (length items))
(delete-tc-item tc (elt items i)))))
+(defmethod item-count :before ((self item-manager))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod item-count ((self item-manager))
+ (length (slot-value self 'items)))
+
(defmethod item-index :before ((self item-manager) (it item))
(declare (ignore it))
(if (gfs:disposed-p self)
Modified: trunk/src/uitoolkit/widgets/list-box.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/list-box.lisp (original)
+++ trunk/src/uitoolkit/widgets/list-box.lisp Sun Sep 10 17:31:01 2006
@@ -56,6 +56,11 @@
(logand orig-flags
(lognot (logior gfs::+lbs-nosel+ gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+))))
+(defun lb-is-single-select (lb)
+ (not (test-native-style lb (logior gfs::+lbs-extendedsel+
+ gfs::+lbs-multiplesel+
+ gfs::+lbs-nosel+))))
+
(defun lb-width (hwnd)
(let ((width (gfs::send-message hwnd gfs::+lb-gethorizontalextent+ 0 0)))
(if (< width 0)
@@ -76,6 +81,90 @@
(setf (slot-value victim 'gfs:handle) nil)
(gfs:dispose victim)))))
+;;; This function is based on the package private select( int, boolean )
+;;; method from SWT 3.2 located in List.java starting on line 998, without
+;;; the additional scrolling logic.
+;;;
+(defun lb-select-item (lb index)
+ (let ((hwnd (gfs:handle lb)))
+
+ ;; sanity-check the index
+ ;;
+ (if (or (< index 0) (>= index (gfs::send-message hwnd gfs::+lb-getcount+ 0 0)))
+ (return-from lb-select-item nil))
+
+ ;; save the index of the top-most item
+ ;;
+ (let ((top-index (gfs::send-message hwnd gfs::+lb-gettopindex+ 0 0)))
+ (cffi:with-foreign-object (top-item-rect-ptr 'gfs::rect)
+ (cffi:with-foreign-object (sel-item-rect-ptr 'gfs::rect)
+
+ ;; get the rectangle for the top-most item which we
+ ;; will repaint at the end
+ ;;
+ (gfs::send-message hwnd gfs::+lb-getitemrect+
+ top-index (cffi:pointer-address top-item-rect-ptr))
+ (let ((redraw-needed (zerop (gfs::is-window-visible hwnd)))
+ (has-sel-item nil))
+
+ ;; if the list box is visible, disable repainting
+ ;;
+ (if redraw-needed
+ (enable-redraw lb nil))
+ (unwind-protect
+ (progn
+ (if (lb-is-single-select lb)
+
+ ;; single-select list boxes must be configured differently
+ ;; from multi-select
+ ;;
+ (let ((old-index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0)))
+ (setf has-sel-item (/= old-index -1))
+
+ ;; get the rectangle for the old selected item
+ ;;
+ (if has-sel-item
+ (gfs::send-message hwnd gfs::+lb-getitemrect+
+ old-index (cffi:pointer-address sel-item-rect-ptr)))
+
+ ;; set the new selection
+ ;;
+ (gfs::send-message hwnd gfs::+lb-setcursel+ index 0))
+
+ ;; configure new selection for multi-select list boxes
+ ;;
+ (let ((focus-index (gfs::send-message hwnd gfs::+lb-getcaretindex+ 0 0)))
+
+ ;; set the new selection
+ ;;
+ (gfs::send-message hwnd gfs::+lb-setsel+ 1 index)
+
+ ;; if there was an item with focus, restore it
+ ;;
+ (if (/= focus-index -1)
+ (gfs::send-message hwnd gfs::+lb-setcaretindex+ focus-index 0)))))
+
+ ;; restore the original top-index, then update the
+ ;; list box and the top item and the selection item
+ ;;
+ (gfs::send-message hwnd gfs::+lb-settopindex+ top-index 0)
+ (when redraw-needed
+ (enable-redraw lb t)
+ (gfs::validate-rect hwnd (cffi:null-pointer))
+ (gfs::invalidate-rect hwnd top-item-rect-ptr 1)
+ (if has-sel-item
+ (gfs::invalidate-rect hwnd sel-item-rect-ptr 1))))))))))
+
+(defun lb-deselect-item (lb index)
+ (let ((hwnd (gfs:handle lb)))
+ (if (or (< index 0) (>= index (gfs::send-message hwnd gfs::+lb-getcount+ 0 0)))
+ (return-from lb-deselect-item nil))
+ (if (lb-is-single-select lb)
+ (let ((curr-index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0)))
+ (if (= curr-index index)
+ (gfs::send-message hwnd gfs::+lb-setcursel+ -1 0)))
+ (gfs::send-message hwnd gfs::+lb-setsel+ 0 index))))
+
;;;
;;; methods
;;;
@@ -202,8 +291,7 @@
size))
(defmethod select-all ((self list-box) flag)
- (when (or (test-native-style self gfs::+lbs-extendedsel+)
- (test-native-style self gfs::+lbs-multiplesel+))
+ (when (test-native-style self (logior gfs::+lbs-extendedsel+ gfs::+lbs-multiplesel+))
(gfs::send-message (gfs:handle self) gfs::+lb-setsel+ (if flag 1 0) #xFFFFFFFF)))
(defmethod selected-count ((self list-box))
@@ -216,8 +304,7 @@
(defmethod selected-items ((self list-box))
(let ((hwnd (gfs:handle self))
(items (slot-value self 'items)))
- (if (and (not (test-native-style self gfs::+lbs-extendedsel+))
- (not (test-native-style self gfs::+lbs-multiplesel+)))
+ (if (lb-is-single-select self)
(let ((index (gfs::send-message hwnd gfs::+lb-getcursel+ 0 0)))
(if (and (>= index 0) (< index (length items)))
(list (elt items index))
Modified: trunk/src/uitoolkit/widgets/list-item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/list-item.lisp (original)
+++ trunk/src/uitoolkit/widgets/list-item.lisp Sun Sep 10 17:31:01 2006
@@ -51,6 +51,12 @@
(error 'gfs:win32-error :detail "LB_GETITEMHEIGHT failed"))
height))
+(defun lb-item-text-length (hwnd index)
+ (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0)))
+ (if (< length 0)
+ (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed"))
+ length))
+
(defun lb-item-text (hwnd index &optional buffer-size)
(if (or (null buffer-size) (<= buffer-size 0))
(setf buffer-size (lb-item-text-length hwnd index)))
@@ -59,12 +65,6 @@
(error 'gfs:win32-error :detail "LB_GETTEXT failed"))
(cffi:foreign-string-to-lisp str-ptr)))
-(defun lb-item-text-length (hwnd index)
- (let ((length (gfs::send-message hwnd gfs::+lb-gettextlen+ index 0)))
- (if (< length 0)
- (error 'gfs:win32-error :detail "LB_GETTEXTLEN failed"))
- length))
-
;;;
;;; methods
;;;
@@ -76,3 +76,9 @@
(if (and owner (cffi:pointer-eq hwnd (gfs:handle owner)))
(gfs::send-message hwnd gfs::+lb-deletestring+ (item-index owner self) 0)))))
(call-next-method))
+
+(defmethod text ((self list-item))
+ (let ((hwnd (gfs:handle self)))
+ (if (or (null hwnd) (cffi:null-pointer-p hwnd))
+ ""
+ (lb-item-text hwnd (item-index (get-widget (thread-context) hwnd) self)))))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Sep 10 17:31:01 2006
@@ -39,6 +39,8 @@
(defclass event-dispatcher () ()
(:documentation "Instances of this class receive events on behalf of user interface objects."))
+(defvar *default-dispatcher* (make-instance 'event-dispatcher))
+
(defclass layout-managed ()
((layout-p
:reader layout-p
@@ -68,7 +70,7 @@
((dispatcher
:accessor dispatcher
:initarg :dispatcher
- :initform (make-instance 'event-dispatcher))
+ :initform *default-dispatcher*)
(callback-event-name
:accessor callback-event-name-of
:initform nil
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Sep 10 17:31:01 2006
@@ -207,6 +207,9 @@
(defgeneric (setf image) (image self)
(:documentation "Sets self's image object."))
+(defgeneric item-count (self)
+ (:documentation "Returns the number of items contained within self."))
+
(defgeneric item-height (self)
(:documentation "Return the height of the area if one of the object's items were displayed."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Sep 10 17:31:01 2006
@@ -141,7 +141,7 @@
(defun show-common-dialog (dlg dlg-func)
(let* ((struct-ptr (gfs:handle dlg))
(retval (funcall dlg-func struct-ptr)))
- (if (and (zerop retval) (not (zerop (gfs::comm-dlg-extended-error))))
+ (if (and (zerop retval) (/= (gfs::comm-dlg-extended-error) 0))
(error 'gfs:comdlg-error :detail (format nil "~a failed" (symbol-name dlg-func))))
retval))
@@ -286,7 +286,7 @@
(gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+))
(defun test-native-style (widget bits)
- (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) bits))
+ (/= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-style+) bits) 0))
(defun test-native-exstyle (widget bits)
- (= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) bits))
+ (/= (logand (gfs::get-window-long (gfs:handle widget) gfs::+gwl-exstyle+) bits) 0))
Modified: trunk/src/uitoolkit/widgets/widget.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget.lisp Sun Sep 10 17:31:01 2006
@@ -207,7 +207,7 @@
(redraw self)))
(defmethod enabled-p ((self widget))
- (not (zerop (gfs::is-window-enabled (gfs:handle self)))))
+ (/= (gfs::is-window-enabled (gfs:handle self)) 0))
(defmethod image :before ((self widget))
(if (gfs:disposed-p self)
@@ -435,4 +435,4 @@
(error 'gfs:disposed-error)))
(defmethod visible-p ((self widget))
- (not (zerop (gfs::is-window-visible (gfs:handle self)))))
+ (/= (gfs::is-window-visible (gfs:handle self)) 0))
More information about the Graphic-forms-cvs
mailing list