Author: junrue Date: Sun Mar 12 21:06:21 2006 New Revision: 36
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp trunk/src/uitoolkit/widgets/flow-layout.lisp trunk/src/uitoolkit/widgets/layout.lisp trunk/src/uitoolkit/widgets/menu-language.lisp trunk/src/uitoolkit/widgets/menu.lisp trunk/src/uitoolkit/widgets/widget-generics.lisp Log: enhance append-submenu so it can take callback or dispatcher
Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun Mar 12 21:06:21 2006 @@ -157,6 +157,12 @@ (gfw:show victim (not (gfw:visible-p victim))) (gfw:layout *layout-tester-win*))))
+(defun check-flow-orient-item (disp menu time) + (declare (ignore disp time)) + (let ((layout (gfw:layout-manager *layout-tester-win*))) + (gfw:check (gfw:item-at menu 0) (find :horizontal (gfw:style-of layout))) + (gfw:check (gfw:item-at menu 1) (find :vertical (gfw:style-of layout))))) + (defun set-flow-horizontal (disp item time rect) (declare (ignorable disp item time rect)) (let ((layout (gfw:layout-manager *layout-tester-win*))) @@ -191,9 +197,9 @@ :callback #'set-flow-vertical)))) (spacing-menu (gfw:defmenusystem ((:item "Decrease") (:item "Increase"))))) - (gfw:append-submenu menu "Margin" margin-menu) - (gfw:append-submenu menu "Orientation" orient-menu) - (gfw:append-submenu menu "Spacing" spacing-menu) + (gfw:append-submenu menu "Margin" margin-menu nil) + (gfw:append-submenu menu "Orientation" orient-menu #'check-flow-orient-item) + (gfw:append-submenu menu "Spacing" spacing-menu nil) (setf it (gfw:append-item menu "Fill" nil nil)) (gfw:check it t) (gfw:append-item menu "Wrap" nil #'(lambda (a0 a1 a2 a3) (format t "wrap: ~a~%" a2)))))
Modified: trunk/src/uitoolkit/widgets/flow-layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/flow-layout.lisp (original) +++ trunk/src/uitoolkit/widgets/flow-layout.lisp Sun Mar 12 21:06:21 2006 @@ -87,7 +87,7 @@ :size size :location pnt)) entries)))) - (reverse entries))) + (nreverse entries)))
;;; ;;; methods
Modified: trunk/src/uitoolkit/widgets/layout.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/layout.lisp (original) +++ trunk/src/uitoolkit/widgets/layout.lisp Sun Mar 12 21:06:21 2006 @@ -45,7 +45,6 @@ (hdwp nil)) (when (and (layout-p win) layout) (setf kids (compute-layout layout win width-hint height-hint)) -(loop for x in kids do (format t "~a~%" (cdr x))) (setf hdwp (gfs::begin-defer-window-pos (length kids))) (loop for k in kids do (let* ((rect (cdr k))
Modified: trunk/src/uitoolkit/widgets/menu-language.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu-language.lisp (original) +++ trunk/src/uitoolkit/widgets/menu-language.lisp Sun Mar 12 21:06:21 2006 @@ -211,9 +211,9 @@ (vector-push-extend it (items owner))))
(defmethod define-submenu ((gen win32-menu-generator) label dispatcher disabled) - (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu) :dispatcher dispatcher)) + (let* ((submenu (make-instance 'menu :handle (gfs::create-popup-menu))) (parent (first (menu-stack-of gen))) - (item (append-submenu parent label submenu))) + (item (append-submenu parent label submenu dispatcher))) (push submenu (menu-stack-of gen)) (enable item (not disabled))))
Modified: trunk/src/uitoolkit/widgets/menu.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/menu.lisp (original) +++ trunk/src/uitoolkit/widgets/menu.lisp Sun Mar 12 21:06:21 2006 @@ -141,7 +141,7 @@ (vector-push-extend item (items owner)) item))
-(defmethod append-submenu ((parent menu) text (submenu menu)) +(defmethod append-submenu ((parent menu) text (submenu menu) disp) (if (or (gfi:disposed-p parent) (gfi:disposed-p submenu)) (error 'gfi:disposed-error)) (let* ((tc (thread-context)) @@ -154,6 +154,16 @@ (put-menuitem tc item) (vector-push-extend item (items parent)) (put-widget tc submenu) + (cond + ((null disp)) + ((functionp disp) + (let ((class (define-dispatcher `((event-activate . ,disp))))) + (setf (dispatcher submenu) (make-instance (class-name class))))) + ((typep disp 'gfw:event-dispatcher) + (setf (dispatcher submenu) disp)) + (t + (error 'gfs:toolkit-error + :detail "callback must be a function, instance of gfw:event-dispatcher, or null"))) item))
(defun menu-cleanup-callback (menu item)
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sun Mar 12 21:06:21 2006 @@ -48,7 +48,7 @@ (defgeneric append-item (object text image dispatcher) (:documentation "Adds the new item with the specified text to the object, and returns the newly-created item."))
-(defgeneric append-submenu (object text submenu) +(defgeneric append-submenu (object text submenu dispatcher) (:documentation "Adds a submenu anchored to a parent menu and returns the corresponding item."))
(defgeneric background-color (object)