Author: junrue Date: Fri May 12 13:20:56 2006 New Revision: 128 Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/windlg.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: dialog :owner-modal and :modeless styles now work, but :application-modal style needs further work Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Fri May 12 13:20:56 2006 @@ -194,11 +194,14 @@ @ref{window}(s). Dialogs typically serve to collect additional information from the user in a specific context. Note that some applications are entirely dialog-based. This class derives from -@ref{window}.@*@* A @emph{modal} dialog constrains the user to respond -to it, whereas a @emph{modeless} dialog allows continued interaction -with other windows. +@ref{window}.@*@* A @emph{modal} dialog forces the user to respond to +it before returning to other application functionality, whereas a +@emph{modeless} dialog does not. @deffn Initarg :owner -Specifies the @ref{owner} of the dialog. +Specifies the @ref{owner} of the dialog. Although no error will be +thrown, the library does not allow @ref{root-window} to be the parent +of any dialog -- the dialog initialization code instead substitutes +@sc{nil} for the owner. @end deffn @deffn Initarg :style @table @code @@ -212,8 +215,9 @@ dialog floats on top of all application-created windows, the user may still interact with other windows and dialogs. @item :owner-modal -Specifies that the dialog is @emph{modal} only in terms of its -@ref{owner} window or dialog. +Specifies that the dialog is @emph{modal} only in relation to its +@ref{owner} (which could be a window or another dialog). This style is +the default if no style keywords are specified. @end table @end deffn @deffn Initarg :text @@ -432,11 +436,10 @@ on the root @ref{window} are somewhat constrained, therefore not all functions normally implemented for other @ref{window} types are available for this @ref{window} type. If an application attempts to -set @code{root-window} as the @ref{owner} of a dialog or -@ref{top-level}, a @ref{toolkit-error} will be thrown. -In a reply to an entry at -@url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}, -Raymond Chen says: +set @code{root-window} as the @ref{owner} of a dialog, the library +will substitute @sc{nil}. This follows guidance provided by Raymond +Chen in a reply to an entry at his blog +@url{http://blogs.msdn.com/oldnewthing/archive/2004/02/24/79212.aspx}: @quotation An owned window is not a child window. Disabling a parent also disables children, but it does NOT disable owned windows. @@ -639,7 +642,7 @@ @end deffn @anchor{event-focus-loss} -@deffn GenericFunction event-focus-gain dispatcher widget time +@deffn GenericFunction event-focus-loss dispatcher widget time Implement this to respond to an object losing keyboard focus. @end deffn Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Fri May 12 13:20:56 2006 @@ -131,26 +131,46 @@ (setf (gfg:foreground-color gc) (gfg:background-color parent)) (gfg:draw-filled-rectangle gc (make-instance 'gfs:rectangle :size (gfw:size panel))))) -(defun open-modal-dlg (disp item time rect) - (declare (ignore disp item time rect)) +(defclass dialog-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp dialog-events) (dlg gfw:dialog) time) + (declare (ignore time)) + (format t "dialog-events event-close called~%") + (call-next-method) + (gfs:dispose dlg)) + +(defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* - :layout (make-instance 'gfw:flow-layout - :margins 8 - :spacing 4 - :style '(:horizontal)) - :style '(:modal))) + :dispatcher (make-instance 'dialog-events) + :layout (make-instance 'gfw:flow-layout + :margins 8 + :spacing 4 + :style '(:horizontal)) + :style style + :text title)) (panel (make-instance 'dlg-test-panel :style '(:border) :parent dlg)) (btn (make-instance 'gfw:button + :callback (lambda (disp btn time rect) + (declare (ignore disp time rect)) + (let ((dlg (gfw:parent btn))) + (gfw:show dlg nil) + (gfs:dispose dlg))) :parent dlg))) (setf (gfw:text btn) "Close") (gfw:pack dlg) (gfw:center-on-owner dlg) - (gfw:show dlg t))) + (gfw:show dlg t) + dlg)) + +(defun open-modal-dlg (disp item time rect) + (declare (ignore disp item time rect)) + (open-dlg "Modal" '(:owner-modal))) (defun open-modeless-dlg (disp item time rect) - (declare (ignore disp item time rect))) + (declare (ignore disp item time rect)) + (open-dlg "Modeless" '(:modeless))) (defun run-windlg-internal () (let ((menubar nil)) Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Fri May 12 13:20:56 2006 @@ -69,4 +69,56 @@ (error 'gfs:disposed-error))) (if (null text) (setf text +default-dialog-title+)) + ;; NOTE: do not allow apps to specify the desktop window as the + ;; owner of the dialog; it would cause the desktop to become + ;; disabled. + ;; + (if (cffi:pointer-eq (gfs:handle owner) (gfs::get-desktop-window)) + (setf owner nil)) (init-window dlg +dialog-classname+ #'register-dialog-class owner text)) + +(defmethod show ((dlg dialog) flag) + (let ((hutility (utility-hwnd (thread-context))) + (app-modal (find :application-modal (style-of dlg))) + (owner-modal (find :owner-modal (style-of dlg))) + (owner (owner dlg)) + (hdlg (gfs:handle dlg))) + (cond + ((and app-modal owner) + ;; FIXME: need to save and restore each window's prior + ;; enabled state + ;; + (visit-top-level-windows (lambda (win) + (unless (or (cffi:pointer-eq (gfs:handle win) hdlg) + (cffi:pointer-eq (gfs:handle win) hutility)) + (enable win (null flag)))))) + ((and owner-modal owner) + (enable owner (null flag)))) + (call-next-method) + (when (and flag (or app-modal owner-modal)) + (message-loop (lambda (gm-code msg-ptr) + (cond + ((or (gfs:disposed-p dlg) (not (visible-p dlg))) + t) ; dialog closed, so exit loop + ((zerop gm-code) + ;; IMPORTANT: allow WM_QUIT to propagate back through + ;; nested message loops to the main loop, so that we + ;; shut down correctly -- whether the system injected + ;; the WM_QUIT or it was something the app did, we + ;; handle the shutdown request the same way. + ;; + (gfs::post-quit-message (cffi:foreign-slot-value msg-ptr + 'gfs::msg + 'gfs::wparam)) + t) + ((= gm-code -1) + (warn 'gfs:win32-warning :detail "get-message failed") + t) + ((/= (gfs::is-dialog-message (gfs:handle dlg) msg-ptr) 0) + ;; It was a dialog message and has been processed, + ;; so nothing else to do. + ;; + nil) + (t + (translate-and-dispatch msg-ptr) + nil))))))) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Fri May 12 13:20:56 2006 @@ -33,6 +33,10 @@ (in-package #:graphic-forms.uitoolkit.widgets) +(defun translate-and-dispatch (msg-ptr) + (gfs::translate-message msg-ptr) + (gfs::dispatch-message msg-ptr)) + (defun default-message-filter (gm-code msg-ptr) (cond ((zerop gm-code) @@ -42,8 +46,7 @@ (warn 'gfs:win32-warning :detail "get-message failed") t) (t - (gfs::translate-message msg-ptr) - (gfs::dispatch-message msg-ptr) + (translate-and-dispatch msg-ptr) nil))) #+clisp (defun startup (thread-name start-fn)