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

Author: junrue Date: Mon Feb 20 21:58:21 2006 New Revision: 16

Modified: trunk/src/packages.lisp trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/control.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp trunk/src/uitoolkit/widgets/widget-with-items.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implement menu item check/uncheck; cleaned up some widget method names; added additional native handle error checking

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Mon Feb 20 21:58:21 2006 @@ -292,6 +292,8 @@ #:background-pattern #:border-width #:caret + #:check + #:check-all #:checked-p #:clear-all #:clear-item @@ -376,7 +378,6 @@ #:hide-lines #:horizontal-scrollbar #:image - #:item-append #:item-at #:item-count #:item-height @@ -422,8 +423,9 @@ #:retrieve-span #:run-default-message-loop #:scroll + #:select #:select-all - #:selected + #:selected-p #:selection-count #:selection-index #:selection-indices @@ -450,6 +452,8 @@ #:traverse-order #:trim-sizes #:unlock + #:uncheck + #:uncheck-all #:update #:vertical-scrollbar #:visible-item-count

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Mon Feb 20 21:58:21 2006 @@ -109,6 +109,10 @@ ((item-disp-class :accessor item-disp-class :initarg :item-disp-class + :initform nil) + (check-test-fn + :accessor check-test-fn + :initarg :check-test-fn :initform nil)))

(defmethod gfw:event-activate ((d child-menu-dispatcher) menu time) @@ -117,10 +121,14 @@ (gfw:with-children (*layout-tester-win* kids) (loop for k in kids do (let ((it (make-instance 'gfw:menu-item))) - (gfw:item-append menu it) + (gfw:append-item menu it) (unless (null (item-disp-class d)) (setf (gfw:dispatcher it) (make-instance (item-disp-class d)))) - (setf (gfw:text it) (gfw:text k)))))) + (setf (gfw:text it) (gfw:text k)) + (unless (null (check-test-fn d)) + (if (funcall (check-test-fn d) k) + (gfw::check it) + (gfw::uncheck it)))))))

(defclass remove-child-dispatcher (gfw:event-dispatcher) ())

@@ -136,9 +144,9 @@ (gfi:dispose victim) (gfw:layout *layout-tester-win*))))

-(defclass hide-child-dispatcher (gfw:event-dispatcher) ()) +(defclass visibility-child-dispatcher (gfw:event-dispatcher) ())

-(defmethod gfw:event-select ((d hide-child-dispatcher) item time rect) +(defmethod gfw:event-select ((d visibility-child-dispatcher) item time rect) (declare (ignorable time rect)) (let ((text (gfw:text item)) (victim nil)) @@ -147,23 +155,11 @@ do (if (string= (gfw:text k) text) (setf victim k)))) (unless (null victim) - (gfw:hide victim) + (if (gfw:visible-p victim) + (gfw:hide victim) + (gfw:show victim)) (gfw:layout *layout-tester-win*))))

-(defclass show-child-dispatcher (gfw:event-dispatcher) ()) - -(defmethod gfw:event-select ((d show-child-dispatcher) item time rect) - (declare (ignorable time rect)) - (let ((text (gfw:text item)) - (victim nil)) - (gfw:with-children (*layout-tester-win* kids) - (loop for k in kids - do (if (string= (gfw:text k) text) - (setf victim k)))) - (unless (null victim) - (gfw:show victim) - (gfw:pack *layout-tester-win*)))) - (defclass layout-tester-exit-dispatcher (gfw:event-dispatcher) ())

(defmethod gfw:event-select ((d layout-tester-exit-dispatcher) item time rect) @@ -177,8 +173,8 @@ (pack-disp (make-instance 'pack-layout-dispatcher)) (add-btn-disp (make-instance 'add-child-dispatcher)) (rem-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'remove-child-dispatcher)) - (hide-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'hide-child-dispatcher)) - (show-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'show-child-dispatcher))) + (vis-menu-disp (make-instance 'child-menu-dispatcher :item-disp-class 'visibility-child-dispatcher + :check-test-fn #'gfw:visible-p))) (setf *layout-tester-win* (make-instance 'gfw:window :dispatcher (make-instance 'layout-tester-events) :layout-manager (make-instance 'gfw:flow-layout))) (gfw:realize *layout-tester-win* nil :style-workspace) @@ -187,18 +183,13 @@ ((:menu "&Children") (:menuitem :submenu ((:menu "Add") (:menuitem "Button" :dispatcher ,add-btn-disp))) - (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp) - (:menuitem :separator))) - (:menuitem :submenu ((:menu "Hide" :dispatcher ,hide-menu-disp) - (:menuitem :separator))) - (:menuitem :submenu ((:menu "Show" :dispatcher ,show-menu-disp) - (:menuitem :separator)))) + (:menuitem :submenu ((:menu "Remove" :dispatcher ,rem-menu-disp))) + (:menuitem :submenu ((:menu "Set Visibility" :dispatcher ,vis-menu-disp)))) ((:menu "&Window") (:menuitem "Pack" :dispatcher ,pack-disp) (:menuitem :submenu ((:menu "Select Layout") (:menuitem "Flow"))) - (:menuitem :submenu ((:menu "Modify Layout") - (:menuitem :separator))))))) + (:menuitem :submenu ((:menu "Modify Layout"))))))) (setf (gfw:menu-bar *layout-tester-win*) menubar) (dotimes (i 3) (add-layout-tester-widget 'gfw:button :push-button))

Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Mon Feb 20 21:58:21 2006 @@ -43,12 +43,14 @@ (error 'gfi:disposed-error)))

(defmethod realize :before ((ctl control) parent &rest style) + (declare (ignore style)) (if (gfi:disposed-p parent) (error 'gfi:disposed-error)) (if (not (gfi:disposed-p ctl)) (error 'gfs:toolkit-error :detail "object already realized")))

(defmethod realize :after ((ctl control) parent &rest style) + (declare (ignorable parent style)) (let ((hwnd (gfi:handle ctl))) (subclass-wndproc hwnd) (put-widget (thread-context) ctl)

Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Mon Feb 20 21:58:21 2006 @@ -95,7 +95,54 @@ (if (zerop (gfs::set-menu-item-info hmenu mid 0 mii-ptr)) (error 'gfs:win32-error :detail "set-menu-item-info failed")))))

-(defun insert-menuitem (howner mid label hbmp) +(defun check-menuitem (hmenu mid checked) + (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type + gfs::state gfs::id gfs::hsubmenu + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+)) + (setf gfs::type 0) + (setf gfs::state (if checked gfs::+mfs-checked+ gfs::+mfs-unchecked+)) + (setf gfs::id mid) + (setf gfs::hsubmenu (cffi:null-pointer)) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata (cffi:null-pointer)) + (setf gfs::cch 0) + (setf gfs::hbmpitem (cffi:null-pointer))) + (if (zerop (gfs::set-menu-item-info hmenu mid 0 mii-ptr)) + (error 'gfs:win32-error :detail "set-menu-item-info failed")))) + +(defun is-menuitem-checked (hmenu mid) + (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type + gfs::state gfs::id gfs::hsubmenu + gfs::hbmpchecked gfs::hbmpunchecked + gfs::idata gfs::tdata gfs::cch + gfs::hbmpitem) + mii-ptr gfs::menuiteminfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)) + (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-state+)) + (setf gfs::type 0) + (setf gfs::state 0) + (setf gfs::id mid) + (setf gfs::hsubmenu (cffi:null-pointer)) + (setf gfs::hbmpchecked (cffi:null-pointer)) + (setf gfs::hbmpunchecked (cffi:null-pointer)) + (setf gfs::idata 0) + (setf gfs::tdata (cffi:null-pointer)) + (setf gfs::cch 0) + (setf gfs::hbmpitem (cffi:null-pointer)) + (if (zerop (gfs::get-menu-item-info hmenu mid 0 mii-ptr)) + (error 'gfs:win32-error :detail "set-menu-item-info failed")) + (= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+)))) + +(defun insert-menuitem (hmenu mid label hbmp) (cffi:with-foreign-string (str-ptr label) (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type @@ -116,7 +163,7 @@ (setf gfs::tdata str-ptr) (setf gfs::cch (length label)) (setf gfs::hbmpitem hbmp)) - (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr)) + (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) (error 'gfs::win32-error :detail "insert-menu-item failed")))))

(defun insert-submenu (hparent mid label hbmp hchildmenu) @@ -145,7 +192,7 @@ (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr)) (error 'gfs::win32-error :detail "insert-menu-item failed")))))

-(defun insert-separator (howner) +(defun insert-separator (hmenu) (cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo) (cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type gfs::state gfs::id gfs::hsubmenu @@ -165,7 +212,7 @@ (setf gfs::tdata (cffi:null-pointer)) (setf gfs::cch 0) (setf gfs::hbmpitem (cffi:null-pointer))) - (if (zerop (gfs::insert-menu-item howner #x7FFFFFFF 1 mii-ptr)) + (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr)) (error 'gfs::win32-error :detail "insert-menu-item failed"))))

(defun sub-menu (m index) @@ -188,6 +235,19 @@ ;;; menu methods ;;;

+(defmethod append-item ((m menu) (it menu-item)) + (let* ((tc (thread-context)) + (id (next-menuitem-id tc)) + (hmenu (gfi:handle m))) + (if (gfi:null-handle-p hmenu) + (error 'gfi:disposed-error)) + (increment-menuitem-id tc) + (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer)) + (setf (item-id it) id) + (setf (slot-value it 'gfi:handle) hmenu) + (put-menuitem tc it) + (call-next-method))) + (defun menu-cleanup-callback (menu item) (let ((tc (thread-context))) (remove-widget tc (gfi:handle menu)) @@ -202,23 +262,22 @@ (error 'gfs:win32-error :detail "destroy-menu failed")))) (setf (slot-value m 'gfi:handle) nil))

-(defmethod item-append ((m menu) (it menu-item)) - (let* ((tc (thread-context)) - (id (next-menuitem-id tc)) - (hmenu (gfi:handle m))) - (if (gfi:null-handle-p hmenu) - (error 'gfi:disposed-error)) - (increment-menuitem-id tc) - (insert-menuitem (gfi:handle m) id " " (cffi:null-pointer)) - (setf (item-id it) id) - (setf (slot-value it 'gfi:handle) hmenu) - (put-menuitem tc it) - (call-next-method))) - ;;; -;;; item methods +;;; menu-item methods ;;;

+(defmethod check ((it menu-item)) + (let ((hmenu (gfi:handle it))) + (if (gfi:null-handle-p hmenu) + (error 'gfs:toolkit-error :detail "null owner menu handle")) + (check-menuitem hmenu (item-id it) t))) + +(defmethod checked-p ((it menu-item)) + (let ((hmenu (gfi:handle it))) + (if (gfi:null-handle-p hmenu) + (error 'gfs:toolkit-error :detail "null owner menu handle")) + (is-menuitem-checked hmenu (item-id it)))) + (defmethod gfi:dispose ((it menu-item)) (setf (dispatcher it) nil) (remove-menuitem (thread-context) it) @@ -254,6 +313,12 @@ (error 'gfs:toolkit-error :detail "null owner menu handle")) (set-menuitem-text hmenu (item-id it) str)))

+(defmethod uncheck ((it menu-item)) + (let ((hmenu (gfi:handle it))) + (if (gfi:null-handle-p hmenu) + (error 'gfs:toolkit-error :detail "null owner menu handle")) + (check-menuitem hmenu (item-id it) nil))) + ;;; ;;; menu language compiler ;;;

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Feb 20 21:58:21 2006 @@ -60,8 +60,14 @@ (defgeneric caret-position (object) (:documentation "Returns a point describing the line number and character position of the caret."))

+(defgeneric check (object) + (:documentation "Sets the object into the checked state.")) + +(defgeneric check-all (object) + (:documentation "Sets all items in this object to the checked state.")) + (defgeneric checked-p (object) - (:documentation "Returns T if the item is checked; nil otherwise.")) + (:documentation "Returns T if the object is in the checked state; nil otherwise."))

(defgeneric clear-item (object index) (:documentation "Clears the item at the zero-based index.")) @@ -117,8 +123,8 @@ (defgeneric deiconified-p (object) (:documentation "Returns T if the object is in its normal, not iconified state."))

-(defgeneric deselect (object index) - (:documentation "Deselects the item at the given zero-based index in the object.")) +(defgeneric deselect (object) + (:documentation "Sets the object into the unselected state."))

(defgeneric deselect-all (object) (:documentation "Deselects all items in the object.")) @@ -201,9 +207,6 @@ (defgeneric image (object) (:documentation "Returns the object's image object if it has one, or nil otherwise."))

-(defgeneric item-append (object other) - (:documentation "Adds the item to the object.")) - (defgeneric item-at (object index) (:documentation "Return the item at the given zero-based index from the object."))

@@ -213,10 +216,10 @@ (defgeneric item-height (object) (:documentation "Return the height of the area if one of the object's items were displayed."))

-(defgeneric item-index (object other) +(defgeneric item-index (object item) (:documentation "Return the zero-based index of the location of the other object in this object."))

-(defgeneric item-owner (object) +(defgeneric item-owner (item) (:documentation "Return the widget containing this item."))

(defgeneric layout (object) @@ -315,10 +318,13 @@ (defgeneric scroll (object dest-pnt src-rect children-too) (:documentation "Scrolls a rectangular region (optionally including children) by copying the source area, then causing the uncovered area of the source to be marked as needing repainting."))

+(defgeneric select (object) + (:documentation "Set this object into the selected state.")) + (defgeneric select-all (object) (:documentation "Set all items of this object to the selected state."))

-(defgeneric selected (object) +(defgeneric selected-p (object) (:documentation "Returns T if the object is in the selected state; nil otherwise."))

(defgeneric selection-count (object) @@ -384,6 +390,12 @@ (defgeneric unlock (object) (:documentation "Allows this object's contents to be modified."))

+(defgeneric uncheck (object) + (:documentation "Sets the object into the unchecked state.")) + +(defgeneric uncheck-all (object) + (:documentation "Sets all items in this object to the unchecked state.")) + (defgeneric update (object) (:documentation "Forces all outstanding paint requests for the object to be processed before this function returns."))

Modified: trunk/src/uitoolkit/widgets/widget-with-items.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-with-items.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-with-items.lisp Mon Feb 20 21:58:21 2006 @@ -33,6 +33,19 @@

(in-package :graphic-forms.uitoolkit.widgets)

+(defmethod append-item :before ((w widget-with-items) (it item)) + (declare (ignore it)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod append-item ((w widget-with-items) (it item)) + (vector-push-extend it (items w))) + +(defmethod clear-item :before ((w widget-with-items) index) + (declare (ignore index)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod clear-item ((w widget-with-items) index) (let ((it (item-at w index))) (delete it (items w) :test #'items-equal-p) @@ -40,24 +53,45 @@ (error 'gfi:disposed-error)) (gfi:dispose it)))

+(defmethod clear-span :before ((w widget-with-items) (sp gfi:span)) + (declare (ignore sp)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod clear-span ((w widget-with-items) (sp gfi:span)) (loop for index from (gfi:span-start sp) to (gfi:span-end sp) collect (clear-item w 0)))

-(defmethod item-append ((w widget-with-items) (i item)) - (vector-push-extend i (items w))) +(defmethod item-at :before ((w widget-with-items) index) + (declare (ignore index)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error)))

(defmethod item-at ((w widget-with-items) index) (elt (items w) index))

-(defmethod (setf item-at) (index (i item) (w widget-with-items)) +(defmethod (setf item-at) :before (index (it item) (w widget-with-items)) + (declare (ignorable index it)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod (setf item-at) (index (it item) (w widget-with-items)) (error 'gfs:toolkit-error :detail "not yet implemented"))

+(defmethod item-count :before ((w widget-with-items)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod item-count ((w widget-with-items)) (length (items w)))

-(defmethod item-index ((w widget-with-items) (i item)) - (let ((pos (position i (items w) :test #'items-equal-p))) +(defmethod item-index :before ((w widget-with-items) (it item)) + (declare (ignore it)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod item-index ((w widget-with-items) (it item)) + (let ((pos (position it (items w) :test #'items-equal-p))) (if (null pos) (return-from item-index 0)) 0))

Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Mon Feb 20 21:58:21 2006 @@ -41,6 +41,11 @@ ;;; widget methods ;;;

+(defmethod ancestor-p :before ((ancestor widget) (descendant widget)) + (declare (ignore descendant)) + (if (gfi:disposed-p ancestor) + (error 'gfi:disposed-error))) + (defmethod ancestor-p ((ancestor widget) (descendant widget)) (let* ((parent-hwnd (gfs::get-ancestor (gfi:handle descendant) gfs::+ga-parent+)) (parent (get-widget (thread-context) parent-hwnd))) @@ -50,6 +55,18 @@ (error 'gfs:toolkit-error :detail "no widget for parent handle")) (ancestor-p ancestor parent)))

+(defmethod checked-p :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod checked-p ((w widget)) + (declare (ignore w)) + nil) + +(defmethod client-size :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod client-size ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize @@ -80,6 +97,10 @@ (defmethod hide ((w widget)) (gfs::show-window (gfi:handle w) gfs::+sw-hide+))

+(defmethod location :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod location ((w widget)) (cffi:with-foreign-object (wi-ptr 'gfs::windowinfo) (cffi:with-foreign-slots ((gfs::cbsize @@ -97,9 +118,12 @@ (gfs::screen-to-client (gfi:handle w) pnt-ptr) (gfi:make-point :x gfs::x :y gfs::y))))))

-(defmethod (setf location) ((pnt gfi:point) (w widget)) +(defmethod (setf location) :before ((pnt gfi:point) (w widget)) + (declare (ignore pnt)) (if (gfi:disposed-p w) - (error 'gfi:disposed-error)) + (error 'gfi:disposed-error))) + +(defmethod (setf location) ((pnt gfi:point) (w widget)) (if (zerop (gfs::set-window-pos (gfi:handle w) (cffi:null-pointer) (gfi:point-x pnt) @@ -108,17 +132,38 @@ gfs::+swp-nosize+)) (error 'gfs:win32-error :detail "set-window-pos failed")))

+(defmethod pack :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod pack ((w widget)) (setf (size w) (preferred-size w -1 -1)))

+(defmethod redraw :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod redraw ((w widget)) (let ((hwnd (gfi:handle w))) (unless (gfi:null-handle-p hwnd) (gfs::invalidate-rect hwnd nil 1))))

+(defmethod selected-p :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + +(defmethod selected-p ((w widget)) + (declare (ignore w)) + nil) + (defmethod size ((w widget)) (client-size w))

+(defmethod (setf size) :before ((sz gfi:size) (w widget)) + (declare (ignore sz)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod (setf size) ((sz gfi:size) (w widget)) (if (gfi:disposed-p w) (error 'gfi:disposed-error)) @@ -137,6 +182,10 @@ (defmethod show ((w widget)) (gfs::show-window (gfi:handle w) gfs::+sw-showna+))

+(defmethod update :before ((w widget)) + (if (gfi:disposed-p w) + (error 'gfi:disposed-error))) + (defmethod update ((w widget)) (let ((hwnd (gfi:handle w))) (unless (gfi:null-handle-p hwnd)