[graphic-forms-cvs] r169 - in trunk: docs/manual src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Mon Jul 3 01:08:13 UTC 2006
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.
+ at end table
+The following style keyword(s) may also be included:
+ at table @code
+ at 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
- at anchor{widget-with-items} items
- at deftp Class widget-with-items
+ at anchor{widget-with-items}
+ at 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}
- at deftp Class window
+ at 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.
- at deffn Reader layout-p
+ at deffn Accessor layout-of
+Accepts or returns the @ref{layout-manager} associated with this
+ at code{window}.
+ at end deffn
+ at deffn Accessor maximum-size
+ at end deffn
+ at 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
- at deffn Accessor layout-of
+ at deffn Reader layout-p => boolean
+Returns T if layout behavior is enabled for the @code{window};
+ at sc{nil} otherwise.
+ at end deffn
+ at deffn Initarg :maximum-size
+ at end deffn
+ at 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)
More information about the Graphic-forms-cvs
mailing list