[graphic-forms-cvs] r128 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Fri May 12 17:20:57 UTC 2006
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
- at ref{window}.@*@* A @emph{modal} dialog constrains the user to respond
-to it, whereas a @emph{modeless} dialog allows continued interaction
-with other windows.
+ at ref{window}.@*@* A @emph{modal} dialog forces the user to respond to
+it before returning to other application functionality, whereas a
+ at 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
+ at 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
- at ref{owner} window or dialog.
+Specifies that the dialog is @emph{modal} only in relation to its
+ at 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
- at ref{top-level}, a @ref{toolkit-error} will be thrown.
-In a reply to an entry at
- 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
+ at 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}
- at deffn GenericFunction event-focus-gain dispatcher widget time
+ at 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)
More information about the Graphic-forms-cvs
mailing list