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

[junrue at common-lisp.net]

Author: junrue
Date: Thu Mar  9 11:45:11 2006
New Revision: 34

Modified:
   trunk/src/packages.lisp
   trunk/src/tests/uitoolkit/layout-tester.lisp
   trunk/src/uitoolkit/widgets/menu-item.lisp
   trunk/src/uitoolkit/widgets/menu.lisp
   trunk/src/uitoolkit/widgets/thread-context.lisp
Log:
update menu append-item to support callback functions in addition to dispatchers

Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp	(original)
+++ trunk/src/packages.lisp	Thu Mar  9 11:45:11 2006
@@ -34,7 +34,7 @@
 (in-package #:graphic-forms-system)
 
 ;;;
-;;; destination for unique symbols generated by the library
+;;; destination for unique symbols generated by GENTEMP
 ;;;
 (defpackage #:graphic-forms.generated
   (:nicknames #:gfgen)

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/layout-tester.lisp	(original)
+++ trunk/src/tests/uitoolkit/layout-tester.lisp	Thu Mar  9 11:45:11 2006
@@ -182,7 +182,7 @@
     (gfw:append-submenu menu "Spacing" spacing-menu)
     (setf it (gfw:append-item menu "Fill" nil nil))
     (gfw:check it t)
-    (gfw:append-item menu "Wrap" nil nil)))
+    (gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2)))))
 
 (defun exit-layout-callback (disp item time rect)
   (declare (ignorable disp item time rect))

Modified: trunk/src/uitoolkit/widgets/menu-item.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu-item.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu-item.lisp	Thu Mar  9 11:45:11 2006
@@ -142,6 +142,20 @@
         (error 'gfs:win32-error :detail "set-menu-item-info failed"))
       (= (logand gfs::state gfs::+mfs-checked+) gfs::+mfs-checked+))))
 
+(defun create-menuitem-with-callback (hmenu disp)
+  (let ((item nil))
+    (cond
+      ((null disp)
+         (setf item (make-instance 'menu-item :handle hmenu)))
+      ((functionp disp)
+         (setf item (make-instance 'menu-item :handle hmenu :callbacks `((gfw:event-select . ,disp)))))
+      ((typep disp 'gfw:event-dispatcher)
+         (setf item (make-instance 'menu-item :handle hmenu :dispatcher disp)))
+      (t
+         (error 'gfs:toolkit-error
+           :detail "callback must be a function, instance of gfw:event-dispatcher, or null")))
+    item))
+
 ;;;
 ;;; methods
 ;;;

Modified: trunk/src/uitoolkit/widgets/menu.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/menu.lisp	(original)
+++ trunk/src/uitoolkit/widgets/menu.lisp	Thu Mar  9 11:45:11 2006
@@ -132,13 +132,11 @@
 
 (defmethod append-item ((owner menu) text image disp)
   (let* ((tc (thread-context))
-         (item (make-instance 'menu-item :dispatcher disp))
-         (id (next-menuitem-id tc))
-         (hmenu (gfi:handle owner)))
-    (increment-menuitem-id tc)
+         (id (increment-menuitem-id tc))
+         (hmenu (gfi:handle owner))
+         (item (create-menuitem-with-callback hmenu disp)))
     (insert-menuitem hmenu id text (cffi:null-pointer))
     (setf (item-id item) id)
-    (setf (slot-value item 'gfi:handle) hmenu)
     (put-menuitem tc item)
     (vector-push-extend item (items owner))
     item))
@@ -147,11 +145,10 @@
   (if (or (gfi:disposed-p parent) (gfi:disposed-p submenu))
     (error 'gfi:disposed-error))
   (let* ((tc (thread-context))
-         (id (next-menuitem-id tc))
+         (id (increment-menuitem-id tc))
          (hparent (gfi:handle parent))
          (hmenu (gfi:handle submenu))
          (item (make-instance 'menu-item :handle hparent)))
-    (increment-menuitem-id tc)
     (insert-submenu hparent id text (cffi:null-pointer) hmenu)
     (setf (item-id item) id)
     (put-menuitem tc item)

Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp	(original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp	Thu Mar  9 11:45:11 2006
@@ -129,5 +129,7 @@
     (slot-value tc 'menuitems-by-id)))
 
 (defmethod increment-menuitem-id ((tc thread-context))
-  "Bump up the next menu item ID."
-  (incf (slot-value tc 'next-menuitem-id)))
+  "Return the next menu item ID; also increment the internal value."
+  (let ((id (next-menuitem-id tc)))
+    (incf (slot-value tc 'next-menuitem-id))
+    id))