[graphic-forms-cvs] r118 - in trunk: docs/manual src src/uitoolkit/widgets

[junrue at common-lisp.net]

Author: junrue
Date: Thu May  4 21:08:48 2006
New Revision: 118

Modified:
   trunk/docs/manual/api.texinfo
   trunk/src/packages.lisp
   trunk/src/uitoolkit/widgets/menu-language.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
   trunk/src/uitoolkit/widgets/widget-generics.lisp
Log:
implemented append-separator method for programmatically adding separators to menus

Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo	(original)
+++ trunk/docs/manual/api.texinfo	Thu May  4 21:08:48 2006
@@ -668,6 +668,11 @@
 the newly-created item.
 @end deffn
 
+ at deffn GenericFunction append-separator self
+Adds a separator item to the object, and returns the newly-created
+item.
+ at end deffn
+
 @deffn GenericFunction append-submenu self text submenu dispatcher
 Adds a submenu anchored to a parent menu and returns the corresponding item.
 @end deffn

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Thu May  4 21:08:48 2006
@@ -310,6 +310,7 @@
     #:alignment
     #:ancestor-p
     #:append-item
+    #:append-separator
     #:append-submenu
     #:background-color
     #:background-pattern

Modified: trunk/src/uitoolkit/widgets/menu-language.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-language.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu-language.lisp	Thu May  4 21:08:48 2006
@@ -202,13 +202,8 @@
     (check item checked)))
 
 (defmethod define-separator ((gen win32-menu-generator))
-  (let* ((owner (first (menu-stack-of gen)))
-         (it (make-instance 'menu-item))
-         (hmenu (gfs:handle owner)))
-    (put-menuitem (thread-context) it)
-    (insert-separator hmenu)
-    (setf (slot-value it 'gfs:handle) hmenu)
-    (vector-push-extend it (items owner))))
+  (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)))

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Thu May  4 21:08:48 2006
@@ -87,7 +87,7 @@
       (if (zerop (gfs::insert-menu-item hparent #x7FFFFFFF 1 mii-ptr))
         (error 'gfs::win32-error :detail "insert-menu-item failed")))))
 
-(defun insert-separator (hmenu)
+(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
@@ -96,10 +96,10 @@
                                gfs::hbmpitem)
                               mii-ptr gfs::menuiteminfo)
       (setf gfs::cbsize (cffi:foreign-type-size 'gfs::menuiteminfo))
-      (setf gfs::mask gfs::+miim-ftype+)
+      (setf gfs::mask (logior gfs::+miim-id+ gfs::+miim-ftype+))
       (setf gfs::type gfs::+mft-separator+)
       (setf gfs::state 0)
-      (setf gfs::id 0)
+      (setf gfs::id mid)
       (setf gfs::hsubmenu (cffi:null-pointer))
       (setf gfs::hbmpchecked (cffi:null-pointer))
       (setf gfs::hbmpunchecked (cffi:null-pointer))
@@ -142,6 +142,19 @@
     (vector-push-extend item (items owner))
     item))
 
+(defmethod append-separator ((owner menu))
+  (if (gfs:disposed-p owner)
+    (error 'gfs:disposed-error))
+  (let* ((tc (thread-context))
+         (id (increment-menuitem-id tc))
+         (howner (gfs:handle owner))
+         (item (make-instance 'menu-item :handle howner)))
+    (insert-separator howner id)
+    (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)
   (if (or (gfs:disposed-p parent) (gfs:disposed-p submenu))
     (error 'gfs:disposed-error))

Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp	(original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp	Thu May  4 21:08:48 2006
@@ -48,6 +48,9 @@
 (defgeneric append-item (self text image dispatcher)
   (: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)
   (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))