[graphic-forms-cvs] r172 - in trunk: . docs/manual src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Jul 3 16:31:38 UTC 2006
Author: junrue
Date: Mon Jul 3 12:31:37 2006
New Revision: 172
Modified:
trunk/README.txt
trunk/docs/manual/api.texinfo
trunk/src/uitoolkit/widgets/menu-language.lisp
trunk/src/uitoolkit/widgets/menu.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-with-items.lisp
Log:
refactored menu item/submenu/separator convenience functions and fixed behavior of :disabled in menu language
Modified: trunk/README.txt
==============================================================================
--- trunk/README.txt (original)
+++ trunk/README.txt Mon Jul 3 12:31:37 2006
@@ -61,18 +61,13 @@
has not been tested with all of them. Therefore, images may not
display properly, expecially when a transparency is selected.
-3. The event-tester application's menu definition specifies that the
- Test Menu | Submenu | Item A item should be disabled but it does
- not get disabled. However, the GFW:ENABLE function does otherwise
- work correctly for menu items.
-
-4. The src/demos/unblocked directory contains a start at a demo
+3. The src/demos/unblocked directory contains a start at a demo
program (a simple game where one clicks on block shapes to
score points, where the rest of the blocks fall down to fill
in the gaps). This demo program is not yet finished, but the
source code can still serve as sample code.
-5. The text-extent generic function currently does not return
+4. The text-extent generic function currently does not return
the correct text height. As a workaround, get the text metrics
for the desired font and base height calculations on that
value. The text-extent function does return the correct width.
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Mon Jul 3 12:31:37 2006
@@ -939,9 +939,11 @@
Returns T if ancestor is an ancestor of descendant; nil otherwise.
@end deffn
- at deffn GenericFunction append-item self text image dispatcher
-Adds the new item with the specified text to the object, and returns
-the newly-created item.
+ at deffn GenericFunction append-item self text image dispatcher &optional disabled checked
+Adds the new item with the specified @code{text}, @code{image}, and
+ at ref{event-dispatcher} to the object, and returns the newly-created item.
+The optional @code{checked} and @code{disabled} arguments can be used
+to set the item's initial state.
@end deffn
@deffn GenericFunction append-separator self
@@ -949,8 +951,10 @@
item.
@end deffn
- at deffn GenericFunction append-submenu self text submenu dispatcher
-Adds a submenu anchored to a parent menu and returns the corresponding item.
+ at deffn GenericFunction append-submenu self text submenu dispatcher &optional disabled checked
+Adds a submenu anchored to a parent menu and returns the corresponding
+menu item. The optional @code{checked} and @code{disabled} arguments can
+be used to set the menu item's initial state.
@end deffn
@deffn GenericFunction cancel-widget self
Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp Mon Jul 3 12:31:37 2006
@@ -196,21 +196,16 @@
(push m (menu-stack-of gen))))
(defmethod define-item ((gen win32-menu-generator) label dispatcher disabled checked image)
- (let* ((owner (first (menu-stack-of gen)))
- (item (append-item owner label image dispatcher)))
- (enable item (not disabled))
- (check item checked)))
+ (append-item (first (menu-stack-of gen)) label image dispatcher disabled checked))
(defmethod define-separator ((gen win32-menu-generator))
(let ((owner (first (menu-stack-of gen))))
(append-separator owner)))
(defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled)
- (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu)))
- (parent (first (menu-stack-of gen)))
- (item (append-submenu parent label submenu dispatcher)))
- (push submenu (menu-stack-of gen))
- (enable item (not disabled))))
+ (let ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))))
+ (append-submenu (first (menu-stack-of gen)) label submenu dispatcher disabled)
+ (push submenu (menu-stack-of gen))))
(defmethod complete-submenu ((gen win32-menu-generator))
(pop (menu-stack-of gen)))
Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp (original)
+++ trunk/src/uitoolkit/widgets/menu.lisp Mon Jul 3 12:31:37 2006
@@ -37,8 +37,14 @@
;;; helper functions
;;;
-(defun insert-menuitem (hmenu mid label hbmp)
- (cffi:with-foreign-string (str-ptr label)
+(defun insert-menuitem (hmenu mid label hbmp hchildmenu disabled checked)
+ (declare (ignore hbmp)) ; FIXME: ignore hbmp until we support images in menu items
+ (let ((info-mask (logior gfs::+miim-id+
+ (if label (logior gfs::+miim-state+ gfs::+miim-string+) gfs::+miim-ftype+)
+ (if hchildmenu gfs::+miim-submenu+)))
+ (info-type (if label 0 gfs::+mft-separator+))
+ (info-state (logior (if checked gfs::+mfs-checked+ 0)
+ (if disabled gfs::+mfs-disabled+ 0))))
(cffi:with-foreign-object (mii-ptr 'gfs::menuiteminfo)
(cffi:with-foreign-slots ((gfs::cbsize gfs::mask gfs::type
gfs::state gfs::id gfs::hsubmenu
@@ -46,69 +52,23 @@
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-string+))
- (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 str-ptr)
- (setf gfs::cch (length label))
- (setf gfs::hbmpitem hbmp))
- (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)
- (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
- 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-string+
- gfs::+miim-submenu+))
- (setf gfs::type 0)
- (setf gfs::state 0)
- (setf gfs::id mid)
- (setf gfs::hsubmenu hchildmenu)
- (setf gfs::hbmpchecked (cffi:null-pointer))
- (setf gfs::hbmpunchecked (cffi:null-pointer))
- (setf gfs::idata 0)
- (setf gfs::tdata str-ptr)
- (setf gfs::cch (length label))
- (setf gfs::hbmpitem hbmp))
- (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
- (error 'gfs::win32-error :detail "insert-menu-item failed")))))
-
-(defun insert-separator (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-ftype+))
- (setf gfs::type gfs::+mft-separator+)
- (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::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr))
- (error 'gfs::win32-error :detail "insert-menu-item failed"))))
+ (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo)
+ gfs::mask info-mask
+ gfs::type info-type
+ gfs::state info-state
+ gfs::id mid
+ gfs::hsubmenu hchildmenu
+ gfs::hbmpchecked (cffi:null-pointer)
+ gfs::hbmpunchecked (cffi:null-pointer)
+ gfs::idata 0
+ gfs::tdata (cffi:null-pointer))
+ (if label
+ (cffi:with-foreign-string (str-ptr label)
+ (setf gfs::tdata str-ptr)
+ (if (zerop (gfs::insert-menu-item hmenu #x7FFFFFFF 1 mii-ptr))
+ (error 'gfs::win32-error :detail "insert-menu-item failed")))
+ (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)
(if (gfs:disposed-p m)
@@ -130,13 +90,13 @@
;;; methods
;;;
-(defmethod append-item ((owner menu) text image disp)
+(defmethod append-item ((owner menu) text image disp &optional disabled checked)
(declare (ignore image)) ; FIXME: temporary measure until we support images in menu items
(let* ((tc (thread-context))
(id (increment-menuitem-id tc))
(hmenu (gfs:handle owner))
(item (create-menuitem-with-callback hmenu disp)))
- (insert-menuitem hmenu id text (cffi:null-pointer))
+ (insert-menuitem hmenu id text (cffi:null-pointer) (cffi:null-pointer) disabled checked)
(setf (item-id item) id)
(put-menuitem tc item)
(vector-push-extend item (items owner))
@@ -149,13 +109,13 @@
(id (increment-menuitem-id tc))
(howner (gfs:handle owner))
(item (make-instance 'menu-item :handle howner)))
- (insert-separator howner id)
+ (insert-menuitem howner id nil (cffi:null-pointer) (cffi:null-pointer) nil nil)
(setf (item-id item) id)
(put-menuitem tc item)
(vector-push-extend item (items owner))
item))
-(defmethod append-submenu ((parent menu) text (submenu menu) disp)
+(defmethod append-submenu ((parent menu) text (submenu menu) disp &optional disabled checked)
(if (or (gfs:disposed-p parent) (gfs:disposed-p submenu))
(error 'gfs:disposed-error))
(let* ((tc (thread-context))
@@ -163,7 +123,7 @@
(hparent (gfs:handle parent))
(hmenu (gfs:handle submenu))
(item (make-instance 'menu-item :handle hparent)))
- (insert-submenu hparent id text (cffi:null-pointer) hmenu)
+ (insert-menuitem hparent id text (cffi:null-pointer) hmenu disabled checked)
(setf (item-id item) id)
(put-menuitem tc item)
(vector-push-extend item (items parent))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Mon Jul 3 12:31:37 2006
@@ -45,13 +45,13 @@
(defgeneric ancestor-p (ancestor descendant)
(:documentation "Returns T if ancestor is an ancestor of descendant; nil otherwise."))
-(defgeneric append-item (self text image dispatcher)
+(defgeneric append-item (self text image dispatcher &optional checked disabled)
(:documentation "Adds the new item with the specified text to the object, and returns the newly-created item."))
(defgeneric append-separator (self)
(:documentation "Add a separator item to the object, and returns the newly-created item."))
-(defgeneric append-submenu (self text submenu dispatcher)
+(defgeneric append-submenu (self text submenu dispatcher &optional checked disabled)
(:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))
(defgeneric border-width (self)
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 Jul 3 12:31:37 2006
@@ -33,8 +33,8 @@
(in-package :graphic-forms.uitoolkit.widgets)
-(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher))
- (declare (ignore text image disp))
+(defmethod append-item :before ((w widget-with-items) text (image gfg:image) (disp event-dispatcher) &optional checked disabled)
+ (declare (ignore text image disp checked disabled))
(if (gfs:disposed-p w)
(error 'gfs:disposed-error)))
More information about the Graphic-forms-cvs
mailing list