[graphic-forms-cvs] r214 - in trunk/src: tests/uitoolkit uitoolkit/graphics

[junrue at common-lisp.net]

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)