Author: junrue Date: Thu May 11 16:41:47 2006 New Revision: 126 Modified: trunk/docs/manual/api.texinfo trunk/src/packages.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp Log: refactored message loop in preparation for supporting app-defined dialogs Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu May 11 16:41:47 2006 @@ -577,9 +577,27 @@ @node event functions @section event functions -@strong{NOTE:} There are (and will be) additional event methods defined -in future releases, they just aren't all documented or implemented at -this time. +@anchor{default-message-filter} +@deffn Function default-message-filter gm-code msg-ptr +Processes messages for all @ref{window}s, non-modal @ref{dialog}s, and +@ref{control}s. Accelerator keys are also translated by this +function. Returns @sc{nil} so that @ref{message-loop} will continue, +unless @code{gm-code} is less than or equal to zero, in which case +@sc{t} is returned so that @ref{message-loop} will +exit. @code{gm-code} is zero when @code{msg-ptr} identifies a +@sc{WM_QUIT} message indicating normal shutdown. If @code{gm-code} is +-1, then the system has indicated an error during message retrieval +that should be reported, followed by an orderly +shutdown. @xref{dialog-message-filter}. +@end deffn + +@anchor{dialog-message-filter} +@deffn Function dialog-message-filter gm-code msg-ptr +This function is similar to @ref{default-message-filter}, except that +it is intended to be called from a nested @code{message-loop} +invocation, usually on behalf of a modal @ref{dialog}. In this case, +the function returns @sc{nil} as long as the dialog continues to live. +@end deffn @deffn GenericFunction event-activate dispatcher widget time Implement this to respond to an object being activated. @@ -656,6 +674,23 @@ Implement this to respond to a tick from a specific timer. @end deffn +@anchor{message-loop} +@deffn Function message-loop msg-filter +This function retrieves messages from the system with the intent of +passing each one to the function specified by @code{msg-filter} so +that it may be translated and dispatched. The return value of the +@code{msg-filter} function determines whether @code{message-loop} +continues or returns, and this termination condition depends on the +context of the message loop being executed. The return value is +@sc{nil} if @code{message-loop} should continue, or not @sc{nil} if +the loop should exit. Two pre-defined implementations of message +filter functions are provided: +@itemize @bullet +@item @ref{default-message-filter} +@item @ref{dialog-message-filter} +@end itemize +@end deffn + @node widget functions @section widget functions Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu May 11 16:41:47 2006 @@ -342,6 +342,7 @@ #:cursor #:cut #:default-item + #:default-message-filter #:defmenu #:delay-of #:disabled-image @@ -420,6 +421,7 @@ #:maximum-size #:menu #:menu-bar + #:message-loop #:minimum-size #:mouse-over-image #:move-above @@ -446,7 +448,6 @@ #:resizable-p #:retrieve-span #:right-margin-of - #:run-default-message-loop #:scroll #:select #:select-all Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Thu May 11 16:41:47 2006 @@ -397,6 +397,12 @@ (erase BOOL)) (defcfun + ("IsDialogMessageA" is-dialog-message) + BOOL + (hwnd HANDLE) + (msg LPTR)) + +(defcfun ("IsWindowEnabled" is-window-enabled) BOOL (hwnd HANDLE)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu May 11 16:41:47 2006 @@ -66,7 +66,7 @@ ;;; helper functions ;;; -(defun run-default-message-loop () +(defun message-loop (msg-filter) (cffi:with-foreign-object (msg-ptr 'gfs::msg) (loop (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))) @@ -78,14 +78,8 @@ gfs::pnt) msg-ptr gfs::msg) (setf (event-time (thread-context)) gfs::time) - (when (zerop gm) - (dispose-thread-context) - (return-from run-default-message-loop gfs::wparam)) - (when (= gm -1) - (warn 'gfs:win32-warning :detail "get-message failed") - (return-from run-default-message-loop gfs::wparam))) - (gfs::translate-message msg-ptr) - (gfs::dispatch-message msg-ptr))))) + (when (funcall msg-filter gm msg-ptr) + (return-from message-loop gfs::wparam))))))) (defmacro hi-word (lparam) `(ash (logand #xFFFF0000 ,lparam) -16)) Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Thu May 11 16:41:47 2006 @@ -33,11 +33,24 @@ (in-package #:graphic-forms.uitoolkit.widgets) +(defun default-message-filter (gm-code msg-ptr) + (cond + ((zerop gm-code) + (dispose-thread-context) + t) + ((= gm-code -1) + (warn 'gfs:win32-warning :detail "get-message failed") + t) + (t + (gfs::translate-message msg-ptr) + (gfs::dispatch-message msg-ptr) + nil))) + #+clisp (defun startup (thread-name start-fn) (declare (ignore thread-name)) (gfg::initialize-magick (cffi:null-pointer)) (funcall start-fn) - (run-default-message-loop)) + (message-loop #'default-message-filter)) #+lispworks (defun startup (thread-name start-fn) (hcl:add-special-free-action 'gfs::native-object-special-action) @@ -46,9 +59,9 @@ (mp:initialize-multiprocessing)) (mp:process-run-function thread-name nil - #'(lambda () (progn - (funcall start-fn) - (run-default-message-loop))))) + (lambda () + (funcall start-fn) + (message-loop #'default-message-filter)))) (defun shutdown (exit-code) (gfg::destroy-magick)