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 -@ref{owner}, based on @code{self}'s current outermost size. +Position @var{self} such that it is centrally located relative to its +@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 -@ref{parent}, based on @code{self}'s current outermost size. +Position @var{self} such that it is centrally located relative to its +@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 -@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 +@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 -@code{self}'s @ref{parent} because the window ownership hierarchy +Returns the @var{owner} of @var{self}, which may be different from +@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 -@code{width-hint} and @code{height-hint} are positive, then each such +@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")))