Author: junrue Date: Sun Aug 13 17:28:31 2006 New Revision: 214 Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp trunk/src/uitoolkit/graphics/icon-bundle.lisp Log: implemented setf icon-image-ref unit-test, fixed bug Modified: trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp ============================================================================== --- trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp (original) +++ trunk/src/tests/uitoolkit/icon-bundle-unit-tests.lisp Sun Aug 13 17:28:31 2006 @@ -99,3 +99,22 @@ (validate-image (gfg:icon-image-ref bundle :large) size 8)) (gfs:dispose bundle)) (assert-true (gfs:disposed-p bundle)))) + +(define-test setf-images-icon-bundle-test + (let ((bundle (make-instance 'gfg:icon-bundle + :images (list (make-instance 'gfg:image :file (merge-pathnames "happy.bmp")) + (make-instance 'gfg:image :file (merge-pathnames "truecolor16x16.bmp"))))) + (happy-image (make-instance 'gfg:image :file (merge-pathnames "happy.bmp"))) + (bw-image (make-instance 'gfg:image :file (merge-pathnames "blackwhite20x16.bmp"))) + (happy-size (gfs:make-size :width 32 :height 32)) + (bw-size (gfs:make-size :width 20 :height 16))) + (unwind-protect + (progn + (assert-equal 2 (gfg:icon-bundle-length bundle)) + (setf (gfg:icon-image-ref bundle 0) bw-image) + (setf (gfg:icon-image-ref bundle 1) happy-image) + (assert-equal 2 (gfg:icon-bundle-length bundle)) + (validate-image (gfg:icon-image-ref bundle 0) bw-size 16000000) + (validate-image (gfg:icon-image-ref bundle 1) happy-size 8)) + (gfs:dispose bundle)) + (assert-true (gfs:disposed-p bundle)))) Modified: trunk/src/uitoolkit/graphics/icon-bundle.lisp ============================================================================== --- trunk/src/uitoolkit/graphics/icon-bundle.lisp (original) +++ trunk/src/uitoolkit/graphics/icon-bundle.lisp Sun Aug 13 17:28:31 2006 @@ -114,6 +114,9 @@ (hicon->image (icon-handle-ref bundle index))) (defun set-icon-image (bundle index image) + (let ((hicon (icon-handle-ref bundle index))) + (if (and (not (gfs:null-handle-p hicon)) (listp (gfs:handle bundle))) + (gfs::destroy-icon hicon))) (setf (icon-handle-ref bundle index) (image->hicon image))) (defsetf icon-image-ref set-icon-image)