Author: junrue Date: Thu Jul 13 20:20:12 2006 New Revision: 197 Modified: trunk/docs/manual/api.texinfo trunk/etc/lisp.exe.manifest trunk/src/packages.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/event-generics.lisp trunk/src/uitoolkit/widgets/event.lisp Log: implemented event-session function, currently untested Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Thu Jul 13 20:20:12 2006 @@ -1172,6 +1172,57 @@ @end table @end deffn +@anchor{event-session} +@deffn GenericFunction event-session dispatcher window phase reason +Implement this method to participate in the system's session shutdown +protocol. When the user chooses to end the session (by logging out or +by shutting down), or if an application calls one of the Win32 +shutdown functions, every application is given a veto option. This +event function will be called at least once for each @ref{top-level} +window in the application.@* + +The MSDN documentation makes the following recommendations for handling +this event: +@itemize @bullet +@item Whenever possible, applications should respect the user's +intentions by allowing the session to end. +@item In the case of a critical operation, provide a @ref{dialog} or +other feedback with information for the user as to consequences +if the application is interrupted at this time. +@item Respond to the @code{:query} event as quickly as possible, leaving +time-consuming cleanup to be done in the session @code{:end} event. +@end itemize + +@table @var +@event-dispatcher-arg +@item window +The @ref{top-level} @ref{window} receiving this event. +@item phase +Identifies which of the two phases this event represents: +@table @code +@item :query +This symbol means that the system is querying the application for +permission to proceed. Return @sc{nil} if there is a reason to veto +the process, or non-@sc{nil} otherwise. +@item :end +This symbol is specified in the subsequent call to @code{event-session}. +It means that the system is going ahead with ending the +session, therefore this is an opportunity for graceful cleanup. +@end table +@item reason +Provides more detail to aid in choosing desired behavior: +@table @code +@item :logoff +The user is logging off. +@item :replacing-file +The application must exit because a file it is using is being +replaced. +@item :shutdown +The system is shutting down or restarting. +@end table +@end table +@end deffn + @anchor{event-timer} @deffn GenericFunction event-timer dispatcher timer Implement this method to respond to expiration of the current Modified: trunk/etc/lisp.exe.manifest ============================================================================== --- trunk/etc/lisp.exe.manifest (original) +++ trunk/etc/lisp.exe.manifest Thu Jul 13 20:20:12 2006 @@ -1,10 +1,10 @@ -<?xml version="1.0" encoding="UTF-8" standalone="yes"?> +<?xml version="1.0" encoding="UTF-8" standalone="yes"?> <assembly xmlns="urn:schemas-microsoft-com:asm.v1" manifestVersion="1.0"> - <assemblyIdentity version="1.0.0.0" processorArchitecture="X86" name="clisp" type="win32"/> + <assemblyIdentity processorArchitecture="x86" name="clisp" type="win32"/> <description>GNU CLISP</description> <dependency> <dependentAssembly> - <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="X86" publicKeyToken="6595b64144ccf1df" language="*"/> + <assemblyIdentity type="win32" name="Microsoft.Windows.Common-Controls" version="6.0.0.0" processorArchitecture="x86" publicKeyToken="6595b64144ccf1df" language="*"/> </dependentAssembly> </dependency> </assembly> Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Thu Jul 13 20:20:12 2006 @@ -395,7 +395,7 @@ #:event-pre-resize #:event-resize #:event-select - #:event-show + #:event-session #:event-timer #:expand #:expanded-p Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Thu Jul 13 20:20:12 2006 @@ -974,6 +974,24 @@ (defconstant +wm-gettextlength+ #x000E) (defconstant +wm-paint+ #x000F) (defconstant +wm-close+ #x0010) +(defconstant +wm-queryendsession+ #x0011) +(defconstant +wm-queryopen+ #x0013) +(defconstant +wm-endsession+ #x0016) +(defconstant +wm-quit+ #x0012) +(defconstant +wm-erasebkgnd+ #x0014) +(defconstant +wm-syscolorchange+ #x0015) +(defconstant +wm-showwindow+ #x0018) +(defconstant +wm-wininichange+ #x001A) +(defconstant +wm-settingchange+ #x001A) +(defconstant +wm-devmodechange+ #x001B) +(defconstant +wm-activateapp+ #x001C) +(defconstant +wm-fontchange+ #x001D) +(defconstant +wm-timechange+ #x001E) +(defconstant +wm-cancelmode+ #x001F) +(defconstant +wm-setcursor+ #x0020) +(defconstant +wm-mouseactivate+ #x0021) +(defconstant +wm-childactivate+ #x0022) +(defconstant +wm-queuesync+ #x0023) (defconstant +wm-getminmaxinfo+ #x0024) (defconstant +wm-painticon+ #x0026) (defconstant +wm-iconerasebkgnd+ #x0027) Modified: trunk/src/uitoolkit/widgets/event-generics.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-generics.lisp (original) +++ trunk/src/uitoolkit/widgets/event-generics.lisp Thu Jul 13 20:20:12 2006 @@ -178,10 +178,10 @@ (:method (dispatcher item) (declare (ignorable dispatcher item)))) -(defgeneric event-show (dispatcher widget) - (:documentation "Implement this to respond to an object being shown.") - (:method (dispatcher widget) - (declare (ignorable dispatcher widget)))) +(defgeneric event-session (dispatcher window phase reason) + (:documentation "Implement this to participate in the session shutdown protocol.") + (:method (dispatcher window phase reason) + (declare (ignorable dispatcher window phase reason)))) (defgeneric event-timer (dispatcher timer) (:documentation "Implement this to respond to a tick from a specific timer.") Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Jul 13 20:20:12 2006 @@ -142,6 +142,18 @@ (defun obtain-event-time () (event-time (thread-context))) +(defun option->reason (lparam) + ;; MSDN says the value is a bitmask, so must be tested bit-wise. + (cond + ((zerop lparam) + :shutdown) + ((oddp lparam) + :replacing-file) + ((= (logand lparam #x80000000) #x80000000) + :logoff) + (t + :shutdown))) + ;;; ;;; process-message methods ;;; @@ -214,6 +226,19 @@ (delete-widget (thread-context) hwnd) 0) +(defmethod process-message (hwnd (msg (eql gfs::+wm-queryendsession+)) wparam lparam) + (declare (ignore wparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (unless (null widget) + (if (event-session (dispatcher widget) widget :query (option->reason lparam)) 1 0)))) + +(defmethod process-message (hwnd (msg (eql gfs::+wm-endsession+)) wparam lparam) + (declare (ignore wparam)) + (let ((widget (get-widget (thread-context) hwnd))) + (unless (null widget) + (event-session (dispatcher widget) widget :end (option->reason lparam)))) + 0) + (defmethod process-message (hwnd (msg (eql gfs::+wm-char+)) wparam lparam) (declare (ignore lparam)) (let* ((tc (thread-context))