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))