[graphic-forms-cvs] r251 - in trunk: . docs/manual src src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri Sep 8 15:32:27 UTC 2006
Author: junrue
Date: Fri Sep 8 11:32:27 2006
New Revision: 251
Added:
trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp
Modified:
trunk/docs/manual/reference.texinfo
trunk/docs/manual/widget-functions.texinfo
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/layout-unit-tests.lisp
trunk/src/tests/uitoolkit/mock-objects.lisp
trunk/src/uitoolkit/widgets/item-manager.lisp
trunk/src/uitoolkit/widgets/item.lisp
trunk/src/uitoolkit/widgets/list-box.lisp
trunk/src/uitoolkit/widgets/list-item.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/tests.lisp
Log:
added unit-tests for item-manager, fixed more bugs
Modified: trunk/docs/manual/reference.texinfo
==============================================================================
--- trunk/docs/manual/reference.texinfo (original)
+++ trunk/docs/manual/reference.texinfo Fri Sep 8 11:32:27 2006
@@ -70,7 +70,7 @@
@end macro
@macro apps-shouldnt-call-function
-This function should typically not be called from application code.
+This function is not intended to be called from application code.
@end macro
@macro event-dispatcher-arg
Modified: trunk/docs/manual/widget-functions.texinfo
==============================================================================
--- trunk/docs/manual/widget-functions.texinfo (original)
+++ trunk/docs/manual/widget-functions.texinfo Fri Sep 8 11:32:27 2006
@@ -36,13 +36,13 @@
@anchor{auto-hscroll-p}
@deffn GenericFunction auto-hscroll-p self => boolean
-Returns T if @code{self} is configured for automatic horizontal scrolling;
+Returns T if @var{self} is configured for automatic horizontal scrolling;
@sc{nil} otherwise. See @ref{auto-vscroll-p} and @ref{enable-auto-scrolling}.
@end deffn
@anchor{auto-vscroll-p}
@deffn GenericFunction auto-vscroll-p self => boolean
-Returns T if @code{self} is configured for automatic vertical scrolling;
+Returns T if @var{self} is configured for automatic vertical scrolling;
@sc{nil} otherwise. See @ref{auto-hscroll-p} and @ref{enable-auto-scrolling}.
@end deffn
@@ -56,9 +56,9 @@
@anchor{capture-mouse}
@defun capture-mouse self
-Enables the @ref{window} identified by @code{self} to receive mouse
+Enables the @ref{window} identified by @var{self} to receive mouse
input events even when the mouse pointer is outside of the bounds
-of @code{self}. Only one window at a time can capture the mouse. This
+of @var{self}. Only one window at a time can capture the mouse. This
function is primarily intended for use with a window in the foreground;
background windows may still capture the mouse, but only mouse move
events will be received and those only when the mouse hotspot is within
@@ -67,15 +67,15 @@
@anchor{center-on-owner}
@deffn GenericFunction center-on-owner self
-Position @code{self} such that it is centrally located relative to its
- at ref{owner}, based on @code{self}'s current outermost size.
+Position @var{self} such that it is centrally located relative to its
+ at ref{owner}, based on @var{self}'s current outermost size.
See also @ref{center-on-parent}.
@end deffn
@anchor{center-on-parent}
@deffn GenericFunction center-on-parent self
-Position @code{self} such that it is centrally located relative to its
- at ref{parent}, based on @code{self}'s current outermost size.
+Position @var{self} such that it is centrally located relative to its
+ at ref{parent}, based on @var{self}'s current outermost size.
See also @ref{center-on-owner}.
@end deffn
@@ -93,7 +93,7 @@
@end deffn
@deffn GenericFunction compute-style-flags self &rest extra-data
-Convert a list of keyword symbols in the object's @code{style} slot to
+Convert a list of keyword symbols in the object's @var{style} slot to
a values pair of native bitmasks; the first conveys normal/standard
flags, whereas the second any extended flags that the system supports.
@end deffn
@@ -106,8 +106,8 @@
@anchor{copy-text}
@deffn GenericFunction copy-text self
This function is a shortcut for a common clipboard transfer operation,
-namely the transfer of text from @code{self} to the system clipboard.
-The existing content of @code{self} remains in place. Some @ref{control}s
+namely the transfer of text from @var{self} to the system clipboard.
+The existing content of @var{self} remains in place. Some @ref{control}s
like the @ref{edit} control have built-in clipboard functionality, and
in such cases, the implementation of this function delegates directly.
See @ref{cut-text}, @ref{paste-text}, and @ref{text-for-pasting-p}.@*@*
@@ -118,8 +118,8 @@
@anchor{cut-text}
@deffn GenericFunction cut-text self
This function is a shortcut for a common clipboard transfer operation,
-namely the transfer of text from @code{self} to the system clipboard
-and removal of content from @code{self}. Some @ref{control}s like the
+namely the transfer of text from @var{self} to the system clipboard
+and removal of content from @var{self}. Some @ref{control}s like the
@ref{edit} control have built-in clipboard functionality, and in such
cases, the implementation of this function delegates directly. For
other @ref{widget}s, this operation is a wrapper around a copy/delete
@@ -135,12 +135,12 @@
Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil}
if none has been set. If @sc{nil} is passed to the corresponding
@sc{setf} function, then no default widget is set. The default widget
-is the one that is selected when @code{self} is active and the user
+is the one that is selected when @var{self} is active and the user
presses @sc{enter}.
@end deffn
@deffn GenericFunction delete-all self
-Removes all content from @code{self}.
+Removes all content from @var{self}.
@end deffn
@deffn GenericFunction delete-item self index
@@ -204,7 +204,7 @@
Specifying T for @var{horizontal} (@var{vertical}) reveals a
scrollbar to attached to the right-hand (bottom) of
@var{self}. Specifying @sc{nil} hides the scrollbar. These flags do
-not affect scrolling behavior in @code{self} -- they only control
+not affect scrolling behavior in @var{self} -- they only control
scrollbar visibility. See @ref{horizontal-scrollbar-p} and
@ref{vertical-scrollbar-p}.
@end deffn
@@ -224,7 +224,7 @@
@end defun
@deffn GenericFunction focus-p self
-Returns @sc{t} if @code{self} currently has keyboard focus; @sc{nil}
+Returns @sc{t} if @var{self} currently has keyboard focus; @sc{nil}
otherwise.
@end deffn
@@ -233,7 +233,7 @@
Interrogates the data structure associated with an instance of
@ref{font-dialog} to obtain the @ref{font} and @ref{color}
corresponding to selections made by the user, and returns
-them via @sc{values}. The @code{gc} parameter should be the same
+them via @sc{values}. The @var{gc} parameter should be the same
@ref{graphics-context} object with which the dialog was created.
If the user cancelled the dialog, the font value will be @sc{nil}.
Also, the color value will be @sc{nil} if the dialog was created with
@@ -242,12 +242,12 @@
@end defun
@deffn GenericFunction give-focus self
-Places keyboard focus on @code{self}.
+Places keyboard focus on @var{self}.
@end deffn
@anchor{horizontal-scrollbar-p}
@deffn GenericFunction horizontal-scrollbar-p self => boolean
-Returns T if @code{self} has been configured to display a horizontal
+Returns T if @var{self} has been configured to display a horizontal
scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}.
@end deffn
@@ -270,7 +270,7 @@
@anchor{line-count}
@deffn GenericFunction line-count self => integer
-Returns the total number of lines (e.g., of text) contained by @code{self}.
+Returns the total number of lines (e.g., of text) contained by @var{self}.
@end deffn
@deffn GenericFunction location self => @ref{point}
@@ -281,9 +281,9 @@
@end deffn
@deffn GenericFunction mapchildren self func => result-list
-Calls @code{func}, which is a function of two arguments, for each
-child of @code{self} and places @code{func}'s return value in
- at code{result-list}. @code{func}'s two arguments are @code{self} and
+Calls @var{func}, which is a function of two arguments, for each
+child of @var{self} and places @var{func}'s return value in
+ at var{result-list}. @var{func}'s two arguments are @var{self} and
the current child.
@end deffn
@@ -343,8 +343,8 @@
@anchor{owner}
@deffn GenericFunction owner self
-Returns the @code{owner} of @code{self}, which may be different from
- at code{self}'s @ref{parent} because the window ownership hierarchy
+Returns the @var{owner} of @var{self}, which may be different from
+ at var{self}'s @ref{parent} because the window ownership hierarchy
includes the relationships between physically separate
@ref{top-level}s and dialogs. And it is possible for a window to be
unowned but still have a @ref{parent}. Consequently, calling
@@ -370,7 +370,7 @@
@anchor{parent}
@deffn GenericFunction parent self => @ref{window}
-Returns the @code{parent} of @code{self}. In the case of @ref{panel}s
+Returns the @code{parent} of @var{self}. In the case of @ref{panel}s
and @ref{control}s, this will be the ancestor dialog, @ref{panel}, or
@ref{top-level} window. In the case of a dialog or @ref{top-level},
then a @ref{root-window} is returned. In the case of a @code{submenu},
@@ -391,8 +391,8 @@
@anchor{paste-text}
@deffn GenericFunction paste-text self
This function is a shortcut for a common clipboard transfer operation,
-namely the transfer of text from the system clipboard to @code{self}.
-Depending on the current selection within @code{self}, the text either
+namely the transfer of text from the system clipboard to @var{self}.
+Depending on the current selection within @var{self}, the text either
gets inserted or existing content is replaced. Some @ref{control}s like the
@ref{edit} control have built-in clipboard functionality, and in such
cases, the implementation of this function delegates directly. See
@@ -403,12 +403,12 @@
@anchor{preferred-size}
@deffn GenericFunction preferred-size self width-hint height-hint
-Implement this function to return @code{self}'s preferred @ref{size};
-that is, the dimensions that @code{self} computes as being the best
+Implement this function to return @var{self}'s preferred @ref{size};
+that is, the dimensions that @var{self} computes as being the best
fit for itself and/or its children. If one or both of
- at code{width-hint} and @code{height-hint} are positive, then each such
+ at var{width-hint} and @var{height-hint} are positive, then each such
parameter is used as a constraint on the @ref{size} calculation -- if
-for example @code{width-hint} is some positive value, then @code{self}
+for example @var{width-hint} is some positive value, then @var{self}
must determine how tall it would be given that width.
@end deffn
@@ -418,7 +418,7 @@
@end defun
@deffn GenericFunction redo-available-p self => boolean
-Returns T if @code{self} has @sc{redo} capability and has an
+Returns T if @var{self} has @sc{redo} capability and has an
operation that can be redone; @sc{nil} otherwise.
@end deffn
@@ -436,11 +436,11 @@
@deffn GenericFunction resizable-p self => boolean
(setf (@strong{resizable-p} @var{self}) @var{boolean})@*
-Returns T if @code{self} can be resized by the user; @sc{nil}
+Returns T if @var{self} can be resized by the user; @sc{nil}
otherwise. The corresponding @sc{setf} function is implemented for
the @ref{top-level} class (but only has meaning when the @code{:frame}
or @code{:workspace} styles are set), allowing the application to
-modify the resizability of @code{self}, whereupon the frame
+modify the resizability of @var{self}, whereupon the frame
decorations are modified appropriately.
@end deffn
@@ -514,14 +514,14 @@
@deffn GenericFunction text self => string
(setf (@strong{text} @var{self}) @var{string})@*
-For a @ref{window} or @ref{dialog}, this function returns @code{self}'s
+For a @ref{window} or @ref{dialog}, this function returns @var{self}'s
titlebar text (which may be blank). For other @ref{widget}s that have a text
component, this function returns that text component. For anything else,
this function returns @sc{nil}.
@end deffn
@deffn GenericFunction text-baseline self => integer
-Returns the y coordinate value (relative to the top of @code{self}'s
+Returns the y coordinate value (relative to the top of @var{self}'s
bounding box) that correlates to the baseline of the text of the
@ref{control}, if any. For controls in which a text baseline is not
meaningful, such as a @ref{label} with an @ref{image}, this function
@@ -544,7 +544,7 @@
@anchor{text-modified-p}
@deffn GenericFunction text-modified-p self => boolean
(setf (@strong{text-modified-p} @var{self}) @var{boolean})@*@*
-Returns T if the text component of @code{self} has been modified by
+Returns T if the text component of @var{self} has been modified by
the user; @sc{nil} otherwise. The corresponding @sc{setf} function
updates the dirty state flag. This function is not implemented for all
widgets, since in some cases there are multiple text components and in
@@ -553,7 +553,7 @@
@anchor{undo-available-p}
@deffn GenericFunction undo-available-p self => boolean
-Returns T if @code{self} has @sc{undo} capability and has an
+Returns T if @var{self} has @sc{undo} capability and has an
operation that can be undone; @sc{nil} otherwise.
@end deffn
@@ -584,7 +584,7 @@
@anchor{vertical-scrollbar-p}
@deffn GenericFunction vertical-scrollbar-p self => boolean
-Returns T if @code{self} has been configured to display a vertical
+Returns T if @var{self} has been configured to display a vertical
scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}.
@end deffn
@@ -595,7 +595,7 @@
@html
@deffn GenericFunction window->display self
Return the @ref{display} object representing the monitor that is nearest
-to @code{self}. The @ref{rectangle} bounding @code{self} is not required
+to @var{self}. The @ref{rectangle} bounding @var{self} is not required
to intersect the returned @ref{display}.
@end deffn
@end html
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Fri Sep 8 11:32:27 2006
@@ -368,6 +368,7 @@
#:cut-text
#:current-font
#:cursor
+ #:data-of
#:default-message-filter
#:default-widget
#:defmenu
Added: trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp
==============================================================================
--- (empty file)
+++ trunk/src/tests/uitoolkit/item-manager-unit-tests.lisp Fri Sep 8 11:32:27 2006
@@ -0,0 +1,134 @@
+;;;;
+;;;; item-manager-unit-tests.lisp
+;;;;
+;;;; Copyright (C) 2006, Jack D. Unrue
+;;;; All rights reserved.
+;;;;
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions
+;;;; are met:
+;;;;
+;;;; 1. Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;
+;;;; 2. Redistributions in binary form must reproduce the above copyright
+;;;; notice, this list of conditions and the following disclaimer in the
+;;;; documentation and/or other materials provided with the distribution.
+;;;;
+;;;; 3. Neither the names of the authors nor the names of its contributors
+;;;; may be used to endorse or promote products derived from this software
+;;;; without specific prior written permission.
+;;;;
+;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY
+;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS-
+;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY
+;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;;;;
+
+(in-package :graphic-forms.uitoolkit.tests)
+
+(defvar *test-hwnd* (cffi:make-pointer 1))
+
+(defun validate-item (expected actual &optional expected-id (expected-hwnd *default-hwnd*))
+ (assert-true (typep actual 'mock-item))
+ (if expected-id
+ (assert-equal expected-id (gfw:item-id actual))
+ (assert-false (zerop (gfw::item-id actual))))
+ (if expected-hwnd
+ (assert-equality #'cffi:pointer-eq expected-hwnd (gfs:handle actual))
+ (assert-equality #'eql expected-hwnd (gfs:handle actual)))
+ (assert-equality #'equal expected (gfw:data-of actual)))
+
+(defun validate-item-array (expected array &optional (expected-hwnd *default-hwnd*))
+ (assert-true (vectorp array))
+ (assert-true (array-has-fill-pointer-p array))
+ (assert-true (adjustable-array-p array))
+ (assert-equal (length expected) (length array))
+ (dotimes (i (length array))
+ (validate-item (elt expected i) (elt array i) nil expected-hwnd)))
+
+(define-test copy-item-sequence-test
+ (let ((values '(a b c)))
+ (validate-item-array values (gfw::copy-item-sequence *test-hwnd* values 'mock-item) *test-hwnd*)
+ (let ((tmp (loop for datum in values
+ collect (make-instance 'mock-item :data datum
+ :handle *test-hwnd*))))
+ (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*))
+ (let ((tmp (make-array 3 :initial-contents (loop for datum in values
+ collect datum))))
+ (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*))
+ (let ((tmp (make-array 3 :initial-contents (loop for datum in values
+ collect (make-instance 'mock-item
+ :data datum
+ :handle *test-hwnd*)))))
+ (validate-item-array values (gfw::copy-item-sequence *test-hwnd* tmp 'mock-item) *test-hwnd*))))
+
+(define-test item-manager-modifications-test
+ (let ((values1 '(a b c))
+ (values2 '(1 2 3))
+ (disp (make-instance 'gfw:event-dispatcher)))
+ (let ((mgr1 (make-instance 'mock-item-manager :items values1))
+ (mgr2 (make-instance 'mock-item-manager :items values2 :handle *test-hwnd*))
+ (mgr3 (make-instance 'mock-item-manager)))
+
+ (gfw::put-widget (gfw::thread-context) mgr3)
+ (unwind-protect
+ (progn
+
+ ;; sanity check initial states
+ ;;
+ (validate-item-array values1 (slot-value mgr1 'gfw::items))
+ (validate-item-array values2 (slot-value mgr2 'gfw::items) *test-hwnd*)
+ (assert-true (zerop (length (slot-value mgr3 'gfw::items))))
+
+ ;; append a new item to each and sanity check again
+ ;;
+ (gfw:append-item mgr1 'd disp)
+ (validate-item-array (append values1 '(d)) (slot-value mgr1 'gfw::items))
+ (gfw:append-item mgr2 4 disp)
+ (validate-item-array (append values2 '(4)) (slot-value mgr2 'gfw::items) *test-hwnd*)
+ (gfw:append-item mgr3 t disp)
+ (validate-item-array (list t) (slot-value mgr3 'gfw::items))
+
+ ;; delete all from mgr1
+ ;;
+ (let ((tmp (gfw:items-of mgr1)))
+ (assert-equal 4 (length tmp))
+ (gfw:delete-all mgr1)
+ (assert-true (zerop (length (gfw:items-of mgr1))))
+ (loop for actual in tmp
+ for expected in (append values1 '(d))
+ do (validate-item expected actual nil nil)))
+
+ ;; delete an item from mgr2 (using delete-item)
+ ;;
+ (let ((tmp (gfw:items-of mgr2)))
+ (gfw:delete-item mgr2 0)
+ (validate-item 1 (first tmp) nil nil)
+ (assert-equal 3 (length (gfw:items-of mgr2)))
+ (loop for actual in (gfw:items-of mgr2)
+ for expected in (subseq (append values2 '(4)) 1 4)
+ do (validate-item expected actual nil *test-hwnd*)))
+
+ ;; delete last item from mgr3 (using dispose)
+ ;;
+ (let ((tmp (gfw:items-of mgr3)))
+ (gfs:dispose (first tmp))
+ (assert-true (zerop (length (gfw:items-of mgr3))))
+ (validate-item t (first tmp) nil nil))
+
+ ;; copy items from mgr2 to mgr1
+ ;;
+ (setf (gfw:items-of mgr1) (gfw:items-of mgr2))
+ (assert-equal 3 (length (gfw:items-of mgr1)))
+ (loop for actual in (gfw:items-of mgr1)
+ for expected in (subseq (append values2 '(4)) 1 4)
+ do (validate-item expected actual nil *test-hwnd*)))
+
+ (gfw::delete-widget (gfw::thread-context) *default-hwnd*)))))
Modified: trunk/src/tests/uitoolkit/layout-unit-tests.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-unit-tests.lisp (original)
+++ trunk/src/tests/uitoolkit/layout-unit-tests.lisp Fri Sep 8 11:32:27 2006
@@ -34,8 +34,8 @@
(in-package :graphic-forms.uitoolkit.tests)
(define-test layout-attributes-test
- (let ((widget1 (make-instance 'mock-widget :handle 1234))
- (widget2 (make-instance 'mock-widget :handle 5678)))
+ (let ((widget1 (make-instance 'mock-widget :handle (cffi:make-pointer 1234)))
+ (widget2 (make-instance 'mock-widget :handle (cffi:make-pointer 5678))))
(let ((data1 `(,widget1 (a 1 b 2)))
(data2 `(,widget2 (a 10 c 30)))
(layout (make-instance 'gfw:layout-manager)))
Modified: trunk/src/tests/uitoolkit/mock-objects.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/mock-objects.lisp (original)
+++ trunk/src/tests/uitoolkit/mock-objects.lisp Fri Sep 8 11:32:27 2006
@@ -37,6 +37,8 @@
(defconstant +default-container-width+ 300)
(defconstant +default-container-height+ 200)
+(defvar *default-hwnd* (cffi:make-pointer #xFFFFFFFF))
+
;;;
;;; stand-in for a window, used as parent of mock-widget
;;;
@@ -80,19 +82,19 @@
:initarg :min-size
:initform (gfs:make-size))))
-(defmethod initialize-instance :after ((widget mock-widget) &key handle &allow-other-keys)
- (setf (slot-value widget 'gfs:handle) (cffi:make-pointer (or handle #xFFFFFFFF))))
+(defmethod initialize-instance :after ((self mock-widget) &key handle &allow-other-keys)
+ (setf (slot-value self 'gfs:handle) (or handle *default-hwnd*)))
-(defmethod gfw:location ((widget mock-widget))
+(defmethod gfw:location ((self mock-widget))
(gfs:make-point))
-(defmethod gfw:minimum-size ((widget mock-widget))
- (gfs:make-size :width (gfs:size-width (min-size-of widget))
- :height (gfs:size-height (min-size-of widget))))
+(defmethod gfw:minimum-size ((self mock-widget))
+ (gfs:make-size :width (gfs:size-width (min-size-of self))
+ :height (gfs:size-height (min-size-of self))))
-(defmethod gfw:preferred-size ((widget mock-widget) width-hint height-hint)
+(defmethod gfw:preferred-size ((self mock-widget) width-hint height-hint)
(let ((size (gfs:make-size))
- (min-size (min-size-of widget)))
+ (min-size (min-size-of self)))
(if (< width-hint 0)
(setf (gfs:size-width size) (gfs:size-width min-size))
(setf (gfs:size-width size) width-hint))
@@ -101,8 +103,30 @@
(setf (gfs:size-height size) height-hint))
size))
-(defmethod gfw:text-baseline ((widget mock-widget))
- (floor (* (gfs:size-height (min-size-of widget)) 3) 4))
+(defmethod gfw:text-baseline ((self mock-widget))
+ (floor (* (gfs:size-height (min-size-of self)) 3) 4))
+
+(defmethod gfw:visible-p ((self mock-widget))
+ (visibility-of self))
+
+;;;
+;;; infrastructure for item-manager unit tests
+;;;
+
+(defclass mock-item (gfw:item) ())
+
+(defclass mock-item-manager (gfw:widget gfw:item-manager) ())
+
+(defmethod initialize-instance :after ((self mock-item-manager) &key handle items &allow-other-keys)
+ (setf (slot-value self 'gfs:handle) (or handle *default-hwnd*))
+ (if items
+ (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) items 'mock-item))))
+
+(defmethod gfw:append-item ((self mock-item-manager) thing (disp gfw:event-dispatcher) &optional checked disabled)
+ (declare (ignore disabled checked))
+ (let ((item (gfw::create-item-with-callback (gfs:handle self) 'mock-item thing disp)))
+ (vector-push-extend item (slot-value self 'gfw::items))
+ item))
-(defmethod gfw:visible-p ((widget mock-widget))
- (visibility-of widget))
+(defmethod (setf gfw:items-of) (new-items (self mock-item-manager))
+ (setf (slot-value self 'gfw::items) (gfw::copy-item-sequence (gfs:handle self) new-items 'mock-item)))
Modified: trunk/src/uitoolkit/widgets/item-manager.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item-manager.lisp (original)
+++ trunk/src/uitoolkit/widgets/item-manager.lisp Fri Sep 8 11:32:27 2006
@@ -51,9 +51,8 @@
(t
(funcall func thing)))))
-(defun copy-item-sequence (parent new-items item-class)
- (let ((hwnd (gfs:handle parent))
- (tc (thread-context))
+(defun copy-item-sequence (handle new-items item-class)
+ (let ((tc (thread-context))
(replacements (make-items-array)))
(cond
((null new-items)
@@ -63,7 +62,7 @@
(let ((item (elt new-items i)))
(if (typep item item-class)
(vector-push-extend item replacements)
- (let ((tmp (make-instance item-class :handle hwnd :data item)))
+ (let ((tmp (make-instance item-class :handle handle :data item)))
(put-item tc tmp)
(vector-push-extend tmp replacements)))))
replacements)
@@ -71,7 +70,7 @@
(loop for item in new-items
do (if (typep item item-class)
(vector-push-extend item replacements)
- (let ((tmp (make-instance item-class :handle hwnd :data item)))
+ (let ((tmp (make-instance item-class :handle handle :data item)))
(put-item tc tmp)
(vector-push-extend tmp replacements))))
replacements)
@@ -101,9 +100,7 @@
(defmethod delete-item ((self item-manager) index)
(let* ((items (slot-value self 'items))
(it (elt items index)))
- (setf (slot-value self 'items) (remove it items :test #'items-equal-p))
- (if (gfs:disposed-p it)
- (error 'gfs:disposed-error))
+ (setf (slot-value self 'items) (remove it items :test #'items-equal))
(gfs:dispose it)))
(defmethod delete-item-span :before ((self item-manager) (sp gfs:span))
@@ -127,7 +124,7 @@
(error 'gfs:disposed-error)))
(defmethod item-index ((self item-manager) (it item))
- (let ((pos (position it (slot-value self 'items) :test #'items-equal-p)))
+ (let ((pos (position it (slot-value self 'items) :test #'items-equal)))
(if (null pos)
(return-from item-index 0))
0))
Modified: trunk/src/uitoolkit/widgets/item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item.lisp (original)
+++ trunk/src/uitoolkit/widgets/item.lisp Fri Sep 8 11:32:27 2006
@@ -51,7 +51,7 @@
:detail "callback must be a function, instance of gfw:event-dispatcher, or null")))
item))
-(defun items-equal-p (item1 item2)
+(defun items-equal (item1 item2)
(= (item-id item1) (item-id item2)))
;;;
@@ -68,16 +68,13 @@
(error 'gfs:toolkit-error :detail "null owner handle")))
(defmethod gfs:dispose ((self item))
- (setf (dispatcher self) nil)
(let ((hwnd (gfs:handle self)))
(unless (or (null hwnd) (cffi:null-pointer-p hwnd))
(let ((owner (get-widget (thread-context) hwnd)))
(if owner
(setf (slot-value owner 'items)
- (remove self (slot-value owner 'items) :test #'items-equal-p))))))
+ (remove self (slot-value owner 'items) :test #'items-equal))))))
(delete-tc-item (thread-context) self)
- (setf (data-of self) nil)
- (setf (item-id self) 0)
(setf (slot-value self 'gfs:handle) nil))
(defmethod initialize-instance :after ((self item) &key callback &allow-other-keys)
Modified: trunk/src/uitoolkit/widgets/list-box.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/list-box.lisp (original)
+++ trunk/src/uitoolkit/widgets/list-box.lisp Fri Sep 8 11:32:27 2006
@@ -134,12 +134,12 @@
estimated-count
(* estimated-count +estimated-text-size+)))))
(if items
- (setf (slot-value self 'items) (copy-item-sequence self items 'list-item)))
+ (setf (slot-value self 'items) (copy-item-sequence (gfs:handle self) items 'list-item)))
(update-from-items self))
(defmethod (setf items-of) (new-items (self list-box))
(lb-delete-all self)
- (setf (slot-value self 'items) (copy-item-sequence self new-items 'list-item))
+ (setf (slot-value self 'items) (copy-item-sequence (gfs:handle self) new-items 'list-item))
(update-from-items self))
(defmethod preferred-size ((self list-box) width-hint height-hint)
Modified: trunk/src/uitoolkit/widgets/list-item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/list-item.lisp (original)
+++ trunk/src/uitoolkit/widgets/list-item.lisp Fri Sep 8 11:32:27 2006
@@ -70,7 +70,6 @@
;;;
(defmethod gfs:dispose ((self list-item))
-(print self)
(let ((index (index-of self))
(howner (gfs:handle self)))
(if howner
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri Sep 8 11:32:27 2006
@@ -55,6 +55,10 @@
(gfs:dispose ,gc)))))
(defmacro with-drawing-disabled ((widget) &body body)
+ ;; FIXME: should this macro use enable-redraw instead?
+ ;; One immediate problem is that only one window can be
+ ;; locked at a time by LockWindowUpdate.
+ ;;
(let ((tmp-widget (gensym)))
`(let ((,tmp-widget ,widget))
(unwind-protect
Modified: trunk/tests.lisp
==============================================================================
--- trunk/tests.lisp (original)
+++ trunk/tests.lisp Fri Sep 8 11:32:27 2006
@@ -45,4 +45,5 @@
(load (concatenate 'string *gf-tests-dir* "layout-unit-tests"))
(load (concatenate 'string *gf-tests-dir* "flow-layout-unit-tests"))
(load (concatenate 'string *gf-tests-dir* "widget-unit-tests"))
+ (load (concatenate 'string *gf-tests-dir* "item-manager-unit-tests"))
(load (concatenate 'string *gf-tests-dir* "misc-unit-tests")))
More information about the Graphic-forms-cvs
mailing list