[graphic-forms-cvs] r253 - in trunk/src: tests/uitoolkit uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Sat Sep  9 00:39:19 2006
New Revision: 253

Modified:
   trunk/src/tests/uitoolkit/widget-tester.lisp
   trunk/src/uitoolkit/widgets/item-manager.lisp
   trunk/src/uitoolkit/widgets/list-box.lisp
Log:
implemented select-all for list-box

Modified: trunk/src/tests/uitoolkit/widget-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/widget-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/widget-tester.lisp	Sat Sep  9 00:39:19 2006
@@ -66,13 +66,13 @@
   (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)
-  (let ((count (gfw:selected-count lb))
-        (items (gfw:items-of lb)))
-    (gfw:enable move-btn (> count 0))
+  (let ((sel-count (gfw:selected-count lb))
+        (item-count (length (gfw:items-of lb))))
+    (gfw:enable move-btn (> sel-count 0))
     (if all-btn
-      (gfw:enable all-btn  (< count (length items))))
+      (gfw:enable all-btn  (and (> item-count 0) (< sel-count item-count))))
     (if none-btn
-      (gfw:enable none-btn (> count 0)))))
+      (gfw:enable none-btn (> sel-count 0)))))
 
 (defun move-lb-content (orig-lb dest-lb)
   (let ((sel-items (gfw:selected-items orig-lb)))
@@ -99,16 +99,20 @@
                                (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 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 btn-all btn-none)))
+                               (manage-lb-button-states lb2 btn-left nil nil)))
          (btn-all-callback   (lambda (disp btn)
-                               (declare (ignore 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))))
+                               (declare (ignore disp btn))
+                               (gfw:select-all lb1 nil)
+                               (manage-lb-button-states lb1 btn-right btn-all btn-none)))
                                
          (outer-panel (make-instance 'gfw:panel :dispatcher panel-disp
                                                 :parent     *widget-tester-win*

Modified: trunk/src/uitoolkit/widgets/item-manager.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/item-manager.lisp	(original)
+++ trunk/src/uitoolkit/widgets/item-manager.lisp	Sat Sep  9 00:39:19 2006
@@ -102,6 +102,8 @@
     (error 'gfs:disposed-error)))
 
 (defmethod delete-item ((self item-manager) index)
+  (if (or (< index 0) (>= index (length (slot-value self 'items))))
+    (error 'gfs:toolkit-error :detail "invalid item index"))
   (multiple-value-bind (new-items victim)
       (gfs::remove-element (slot-value self 'items) index #'make-items-array)
     (setf (slot-value self 'items) new-items)
@@ -116,10 +118,6 @@
   (if (gfs:disposed-p self)
     (error 'gfs:disposed-error)))
 
-(defmethod delete-span ((self item-manager) (sp gfs:span))
-  (dotimes (i (1+ (- (gfs:span-end sp) (gfs:span-start sp))))
-    (delete-item self (gfs:span-start sp))))
-
 (defmethod gfs:dispose ((self item-manager))
   (let ((items (slot-value self 'items))
         (tc (thread-context)))

Modified: trunk/src/uitoolkit/widgets/list-box.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/list-box.lisp	(original)
+++ trunk/src/uitoolkit/widgets/list-box.lisp	Sat Sep  9 00:39:19 2006
@@ -123,6 +123,13 @@
             do (gfs:dispose item))
     (enable-redraw self t)))
 
+(defmethod delete-span ((self list-box) (span gfs:span))
+  (enable-redraw self nil)
+  (unwind-protect
+      (dotimes (i (1+ (- (gfs:span-end span) (gfs:span-start span))))
+        (delete-item self (gfs:span-start span)))
+    (enable-redraw self t)))
+
 (defmethod initialize-instance :after ((self list-box) &key estimated-count items parent &allow-other-keys)
   (initialize-comctl-classes gfs::+icc-standard-classes+)
   (multiple-value-bind (std-style ex-style)
@@ -194,6 +201,11 @@
       (incf (gfs:size-width size) (vertical-scrollbar-width)))
     size))
 
+(defmethod select-all ((self list-box) flag)
+  (when (or (test-native-style self gfs::+lbs-extendedsel+)
+            (test-native-style self gfs::+lbs-multiplesel+))
+    (gfs::send-message (gfs:handle self) gfs::+lb-setsel+ (if flag 1 0) #xFFFFFFFF)))
+
 (defmethod selected-count ((self list-box))
   (let ((hwnd (gfs:handle self)))
     (if (test-native-style self gfs::+lbs-nosel+)