Author: junrue Date: Sun Jul 2 21:08:12 2006 New Revision: 169
Modified: trunk/docs/manual/api.texinfo trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/thread-context.lisp trunk/src/uitoolkit/widgets/widget-classes.lisp trunk/src/uitoolkit/widgets/widget-utils.lisp trunk/src/uitoolkit/widgets/window.lisp Log: implemented keyboard navigation for windows and modeless dialogs
Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun Jul 2 21:08:12 2006 @@ -679,31 +679,37 @@ boundaries of the window. @end deffn @deffn Initarg :style -The :style initarg is a list of keywords that define the overall +The @code{:style} initarg is a list of keywords that define the overall look-and-feel of the window being created. Applications may choose -from one of the following primary style keywords: +from one of the following primary styles: @table @code @item :borderless -a window with a one-pixel border (so not really @emph{borderless} in the -strictest sense); no frame icon, system menu, minimize/maximize buttons, -or close buttons; the system does not paint the background +Specifies a window with a one-pixel border (so not really @emph{borderless} +in the strictest sense); no frame icon, system menu, minimize/maximize +buttons, or close buttons; the system does not paint the background. @item :frame -the standard top-level frame style with system menu, close box, and -minimize/maximize buttons; this window type is resizable; it differs +Specifies the standard top-level frame style with system menu, close box, +and minimize/maximize buttons; this window type is resizable; it differs from the @code{:workspace} style in that the application is completely -responsible for painting the contents +responsible for painting the contents. @item :miniframe -a resizable window with a shorter than normal caption; has a close box -but no system menu or minimize/maximize buttons; the system does not -paint the background +Specifies a resizable window with a shorter than normal caption; has a +close box but no system menu or minimize/maximize buttons; the system +does not paint the background. @item :palette -similar to the @code{:miniframe} style, but in this case the window -does not have a resize frame; the system does not paint the background +Similar to the @code{:miniframe} style, except that this style also +restricts the window from having a resize frame. @item :workspace -the standard top-level frame style with system menu, close box, and -minimize/maximize buttons; this window type is resizable; it differs +Specifies the standard top-level frame style with system menu, close box, +and minimize/maximize buttons; this window type is resizable; it differs from the @code{:frame} style in that the system paints the background -using the @sc{color_appworkspace} color scheme +using the @sc{color_appworkspace} Win32 color scheme. +@end table +The following style keyword(s) may also be included: +@table @code +@item :keyboard-navigation +Enables keyboard traversal of controls within the @code{window} as if +it were a @ref{dialog}. @end table @end deffn @end deftp @@ -716,8 +722,8 @@ behavior of the widget; style keywords are widget-specific. @end deftp
-@anchor{widget-with-items} items -@deftp Class widget-with-items +@anchor{widget-with-items} +@deftp Class widget-with-items items The widget-with-items class is the base class for objects composed of sub-items. It derives from @ref{widget}. The @code{items} slot is an @sc{adjustable} @sc{vector} containing @ref{item} objects, @@ -725,13 +731,27 @@ @end deftp
@anchor{window} -@deftp Class window +@deftp Class window layout-p layout maximum-size minimum-size This is the base class for user-defined @ref{widget}s that serve as containers. -@deffn Reader layout-p +@deffn Accessor layout-of +Accepts or returns the @ref{layout-manager} associated with this +@code{window}. +@end deffn +@deffn Accessor maximum-size +@end deffn +@deffn Accessor minimum-size @end deffn @deffn Initarg :layout +Accepts a @ref{layout-manager} object whose responsibility is to manage +the direct children of this @code{window}. @end deffn -@deffn Accessor layout-of +@deffn Reader layout-p => boolean +Returns T if layout behavior is enabled for the @code{window}; +@sc{nil} otherwise. +@end deffn +@deffn Initarg :maximum-size +@end deffn +@deffn Initarg :minimum-size @end deffn @end deftp
Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun Jul 2 21:08:12 2006 @@ -127,7 +127,7 @@
(defconstant +ccerr-choosecolorcodes+ #x5000)
-(defconstant +cderr-dialogfailure+ #xffff) +(defconstant +cderr-dialogfailure+ #xFFFF) (defconstant +cderr-generalcodes+ #x0000) (defconstant +cderr-structsize+ #x0001) (defconstant +cderr-initialization+ #x0002) @@ -138,8 +138,8 @@ (defconstant +cderr-loadresfailure+ #x0007) (defconstant +cderr-lockresfailure+ #x0008) (defconstant +cderr-memallocfailure+ #x0009) -(defconstant +cderr-memlockfailure+ #x000a) -(defconstant +cderr-nohook+ #x000b) +(defconstant +cderr-memlockfailure+ #x000A) +(defconstant +cderr-nohook+ #x000B) (defconstant +cderr-registermsgfail+ #x000C)
(defconstant +cf-screenfonts+ #x00000001)
Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Sun Jul 2 21:08:12 2006 @@ -168,6 +168,7 @@ ;; (if (cffi:pointer-eq (gfs:handle owner) (gfs::get-desktop-window)) (setf owner nil)) + (push :keyboard-navigation (style-of self)) ;; FIXME: check if owner is actually a top-level or dialog, and if not, ;; walk up the ancestors until one is found. Only top level hwnds can ;; be owners.
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/thread-context.lisp (original) +++ trunk/src/uitoolkit/widgets/thread-context.lisp Sun Jul 2 21:08:12 2006 @@ -50,6 +50,7 @@ (next-widget-id :initform 100 :reader next-widget-id) (size-event-size :initform (gfs:make-size) :accessor size-event-size) (widgets-by-hwnd :initform (make-hash-table :test #'equal)) + (kbdnav-widgets :initform nil :accessor kbdnav-widgets) (timers-by-id :initform (make-hash-table :test #'equal)) (top-level-visitor-func :initform nil :accessor top-level-visitor-func) (top-level-visitor-results :initform nil :accessor top-level-visitor-results) @@ -149,6 +150,31 @@ "Store the widget currently under construction." (setf (slot-value tc 'wip) nil))
+(defmethod put-kbdnav-widget ((tc thread-context) (widget widget)) + (if (find :keyboard-navigation (style-of widget)) + (setf (kbdnav-widgets tc) (push widget (kbdnav-widgets tc))))) + +(defmethod remove-kbdnav-widget ((tc thread-context) (widget widget)) + (setf (kbdnav-widgets tc) + (remove-if (lambda (hwnd) (cffi:pointer-eq (gfs:handle widget) hwnd)) + (kbdnav-widgets tc) + :key #'gfs:handle))) + +(defmethod intercept-kbdnav-message ((tc thread-context) msg-ptr) + (let ((widgets (kbdnav-widgets tc))) + (unless widgets + (return-from intercept-kbdnav-message nil)) + (let ((widget (first widgets))) + (if (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0) + (return-from intercept-kbdnav-message widget)) + (setf widget (find-if (lambda (w) (/= (gfs::is-dialog-message (gfs:handle w) msg-ptr))) + (rest widgets))) + (when (and widget (/= (gfs::is-dialog-message (gfs:handle widget) msg-ptr) 0)) + (let ((tmp (remove-kbdnav-widget tc widget))) + (setf (kbdnav-widgets tc) (push widget tmp))) + (return-from intercept-kbdnav-message widget)))) + nil) + (defmethod get-menuitem ((tc thread-context) id) "Returns the menu item identified by id." (gethash id (slot-value tc 'menuitems-by-id)))
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-classes.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sun Jul 2 21:08:12 2006 @@ -81,7 +81,7 @@
(defclass widget (event-source) ((style - :reader style-of + :accessor style-of :initarg :style :initform nil)) (:documentation "The widget class is the base class for all windowed user interface objects."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget-utils.lisp (original) +++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sun Jul 2 21:08:12 2006 @@ -48,6 +48,8 @@ ((= gm-code -1) (warn 'gfs:win32-warning :detail "get-message failed") t) + ((intercept-kbdnav-message (thread-context) msg-ptr) + nil) (t (translate-and-dispatch msg-ptr) nil)))
Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Sun Jul 2 21:08:12 2006 @@ -57,6 +57,8 @@ (let ((hwnd (gfs:handle win))) (if (not hwnd) ; handle slot should have been set during create-window (error 'gfs:win32-error :detail "create-window failed")) + (if (find :keyboard-navigation (style-of win)) + (put-kbdnav-widget tc win)) (put-widget tc win))))
#+lispworks @@ -191,6 +193,10 @@ (gfs:size-height new-size) (- gfs::bottom gfs::top))) new-size))
+(defmethod gfs:dispose ((self window)) + (remove-kbdnav-widget (thread-context) self) + (call-next-method)) + (defmethod enable-layout :before ((win window) flag) (declare (ignore flag)) (if (gfs:disposed-p win)