Author: junrue
Date: Sat May 13 19:57:06 2006
New Revision: 130
Modified:
trunk/docs/manual/api.texinfo
trunk/src/packages.lisp
trunk/src/tests/uitoolkit/windlg.lisp
trunk/src/uitoolkit/system/system-constants.lisp
trunk/src/uitoolkit/system/user32.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/dialog.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/label.lisp
trunk/src/uitoolkit/widgets/panel.lisp
trunk/src/uitoolkit/widgets/widget-classes.lisp
trunk/src/uitoolkit/widgets/widget-generics.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
trunk/src/uitoolkit/widgets/window.lisp
Log:
progress towards proper keyboard traversal in dialogs
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Sat May 13 19:57:06 2006
@@ -276,7 +276,7 @@
@anchor{file-dialog}
@deftp Class file-dialog open-mode
-This class provides a standard @ref{dialog} for navigating the file
+This class provides a standard dialog for navigating the file
system to select or enter file names. A variety of configurations are
possible; however, please note that the following behaviors are
implemented regardless of other style flags or initarg values:
@@ -290,9 +290,14 @@
steps manually, in which case the @ref{file-dialog-paths} function can
be used to obtain the user's selection(s). Unless the
@code{:multiple-select} style keyword is specified, there will at most
-be one selected file returned, and possibly zero if the user cancelled
-the dialog. Also, manual construction of an instance must be followed
-by an explicit call to @ref{dispose}.@*@*
+be one selected file returned. In either case, zero is returned if the
+user cancelled the dialog. Also, manual construction of an instance
+must be followed by an explicit call to @ref{dispose}.@*@*
+Like other system dialogs, @code{file-dialog} is derived from @ref{widget}
+rather than @ref{dialog} since the majority of its functionality is
+implemented by the system and is not directly extensible by applications.
+@strong{NOTE:} A future release of Graphic-Forms will provide a
+customization mechanism.@*@*
@deffn Initarg :default-extension
Specifies a default extension to be appended to a file name if
the user fails to provide one. Any embedded periods @samp{.} will
@@ -783,11 +788,12 @@
enclose the specified desired client area and this object's trim.
@end deffn
-@deffn GenericFunction default-button self button
-Returns the default @ref{button} set for a @ref{dialog}, or @sc{nil}
-if none has been set. If @code{button} is @sc{nil}, then no default
-button is set. The default button is the button that is selected when
-@code{self} is active and the user presses @sc{enter}.
+@deffn GenericFunction default-widget self
+Returns the default @ref{widget} set for a @ref{dialog}, or @sc{nil}
+if none has been set. If @sc{nil} is passed to the corresponding
+@sc{setf} function, then no default widget is set. The default widget
+is the one that is selected when @code{self} is active and the user
+presses @sc{enter}.
@end deffn
@deffn GenericFunction display-to-object self pnt
Modified: trunk/src/packages.lisp
==============================================================================
--- trunk/src/packages.lisp (original)
+++ trunk/src/packages.lisp Sat May 13 19:57:06 2006
@@ -341,8 +341,8 @@
#:current-font
#:cursor
#:cut
- #:default-item
#:default-message-filter
+ #:default-widget
#:defmenu
#:delay-of
#:disabled-image
Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp (original)
+++ trunk/src/tests/uitoolkit/windlg.lisp Sat May 13 19:57:06 2006
@@ -164,6 +164,7 @@
:parent dlg))
(ok-btn (make-instance 'gfw:button
:callback #'btn-callback
+ :style '(:default-button)
:text "OK"
:parent btn-panel))
(cancel-btn (make-instance 'gfw:button
Modified: trunk/src/uitoolkit/system/system-constants.lisp
==============================================================================
--- trunk/src/uitoolkit/system/system-constants.lisp (original)
+++ trunk/src/uitoolkit/system/system-constants.lisp Sat May 13 19:57:06 2006
@@ -72,6 +72,15 @@
(defconstant +blt-captureblt+ #x40000000)
(defconstant +blt-nomirrorbitmap+ #x80000000)
+(defconstant +bm-getcheck+ #x00f0)
+(defconstant +bm-setcheck+ #x00f1)
+(defconstant +bm-getstate+ #x00f2)
+(defconstant +bm-setstate+ #x00f3)
+(defconstant +bm-setstyle+ #x00f4)
+(defconstant +bm-click+ #x00f5)
+(defconstant +bm-getimage+ #x00f6)
+(defconstant +bm-setimage+ #x00f7)
+
(defconstant +bs-solid+ 0)
(defconstant +bs-null+ 1)
(defconstant +bs-hollow+ 1)
@@ -113,6 +122,12 @@
(defconstant +bs-flat+ #x00008000)
(defconstant +bs-rightbutton+ #x00000020)
+(defconstant +bst-unchecked+ #x0000)
+(defconstant +bst-checked+ #x0001)
+(defconstant +bst-indeterminate+ #x0002)
+(defconstant +bst-pushed+ #x0004)
+(defconstant +bst-focus+ #x0008)
+
(defconstant +cbm-init+ #x04)
(defconstant +cchdevicename+ 32)
@@ -194,6 +209,10 @@
(defconstant +dib-rgb-colors+ 0)
(defconstant +dib-pal-colors+ 1)
+(defconstant +dm-getdefid+ #x0400)
+(defconstant +dm-setdefid+ #x0401)
+(defconstant +dm-reposition+ #x0402)
+
(defconstant +dt-top+ #x00000000)
(defconstant +dt-left+ #x00000000)
(defconstant +dt-center+ #x00000001)
@@ -292,6 +311,19 @@
(defconstant +hs-cross+ 4)
(defconstant +hs-diagcross+ 5)
+(defconstant +idok+ 1)
+(defconstant +idcancel+ 2)
+(defconstant +idabort+ 3)
+(defconstant +idretry+ 4)
+(defconstant +idignore+ 5)
+(defconstant +idyes+ 6)
+(defconstant +idno+ 7)
+(defconstant +idclose+ 8)
+(defconstant +idhelp+ 9)
+(defconstant +idtryagain+ 10)
+(defconstant +idcontinue+ 11)
+(defconstant +idtimeout+ 32000)
+
(defconstant +image-bitmap+ 0)
(defconstant +image-icon+ 1)
(defconstant +image-cursor+ 2)
@@ -766,6 +798,15 @@
(defconstant +wm-paint+ #x000F)
(defconstant +wm-close+ #x0010)
(defconstant +wm-getminmaxinfo+ #x0024)
+(defconstant +wm-painticon+ #x0026)
+(defconstant +wm-iconerasebkgnd+ #x0027)
+(defconstant +wm-nextdlgctl+ #x0028)
+(defconstant +wm-spoolerstatus+ #x002A)
+(defconstant +wm-drawitem+ #x002B)
+(defconstant +wm-measureitem+ #x002C)
+(defconstant +wm-deleteitem+ #x002D)
+(defconstant +wm-vkeytoitem+ #x002E)
+(defconstant +wm-chartoitem+ #x002F)
(defconstant +wm-setfont+ #x0030)
(defconstant +wm-getfont+ #x0031)
(defconstant +wm-ncmousemove+ #x00A0)
@@ -848,8 +889,10 @@
(defconstant +ws-hscroll+ #x00100000)
(defconstant +ws-sysmenu+ #x00080000)
(defconstant +ws-thickframe+ #x00040000)
+(defconstant +ws-group+ #x00020000)
(defconstant +ws-minimizebox+ #x00020000)
(defconstant +ws-maximizebox+ #x00010000)
+(defconstant +ws-tabstop+ #x00010000)
(defconstant +ws-popupwindow+ #x80880000)
(defconstant +ws-overlappedwindow+ #x00CF0000)
Modified: trunk/src/uitoolkit/system/user32.lisp
==============================================================================
--- trunk/src/uitoolkit/system/user32.lisp (original)
+++ trunk/src/uitoolkit/system/user32.lisp Sat May 13 19:57:06 2006
@@ -108,6 +108,14 @@
(flags UINT))
(defcfun
+ ("DefDlgProcA" def-dlg-proc)
+ LRESULT
+ (hwnd HANDLE)
+ (msg UINT)
+ (wp WPARAM)
+ (lp LPARAM))
+
+(defcfun
("DefWindowProcA" def-window-proc)
LRESULT
(hwnd HANDLE)
@@ -367,6 +375,13 @@
(monitor-info LPTR))
(defcfun
+ ("GetNextDlgTabItem" get-next-dlg-tab-item)
+ HANDLE
+ (hdlg HANDLE)
+ (hctl HANDLE)
+ (flag BOOL))
+
+(defcfun
("GetParent" get-parent)
HANDLE
(hwnd HANDLE))
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Sat May 13 19:57:06 2006
@@ -39,7 +39,8 @@
(defmethod compute-style-flags ((btn button) &rest extra-data)
(declare (ignore extra-data))
- (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)))
+ (let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+))
+ (style (style-of btn)))
(loop for sym in (style-of btn)
do (cond
;; primary button styles
@@ -54,6 +55,8 @@
(setf std-flags (logior std-flags gfs::+bs-radiobutton+)))
((eq sym :toggle-button)
(setf std-flags (logior std-flags gfs::+bs-pushbox+)))))
+ (if (null style)
+ (logior std-flags gfs::+bs-pushbutton+))
(values std-flags 0)))
(defmethod initialize-instance :after ((btn button) &key parent text &allow-other-keys)
@@ -63,9 +66,12 @@
(or text " ")
(gfs:handle parent)
std-style
- ex-style)))
+ ex-style
+ (increment-widget-id (thread-context)))))
(if (not hwnd)
(error 'gfs:win32-error :detail "create-window failed"))
+ (unless (zerop (logand std-style gfs::+bs-defpushbutton+))
+ (gfs::send-message (gfs:handle parent) gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0))
(setf (slot-value btn 'gfs:handle) hwnd)))
(init-control btn))
Modified: trunk/src/uitoolkit/widgets/dialog.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/dialog.lisp (original)
+++ trunk/src/uitoolkit/widgets/dialog.lisp Sat May 13 19:57:06 2006
@@ -34,6 +34,7 @@
(in-package :graphic-forms.uitoolkit.widgets)
(defconstant +default-dialog-title+ " ")
+(defconstant +dlgwindowextra+ 48)
;;;
;;; helper functions
@@ -45,7 +46,8 @@
(logior gfs::+cs-dblclks+
gfs::+cs-savebits+
gfs::+cs-bytealignwindow+)
- gfs::+color-btnface+))
+ gfs::+color-btnface+
+ +dlgwindowextra+))
;;;
;;; methods
@@ -63,7 +65,45 @@
(declare (ignore time))
(show dlg nil))
-(defmethod initialize-instance :after ((dlg dialog) &key owner text &allow-other-keys)
+(defmethod default-widget :before ((self dialog))
+ (if (gfs:disposed-p self)
+ (error 'gfs:disposed-error)))
+
+(defmethod default-widget ((self dialog))
+ (let ((def-widget nil))
+ (visit-child-widgets self (lambda (parent kid)
+ (declare (ignore parent))
+ (if (= (gfs::get-window-long (gfs:handle kid) gfs::+gwlp-id+)
+ gfs::+idok+)
+ (setf def-widget kid))))
+ def-widget))
+
+(defmethod (setf default-widget) :before ((def-widget widget) (self dialog))
+ (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget))
+ (error 'gfs:disposed-error)))
+
+(defmethod (setf default-widget) ((def-widget widget) (self dialog))
+ (when (or (not (typep def-widget 'button))
+ (and (style-of def-widget)
+ (null (find :push-button (style-of def-widget)))))
+ (warn 'gfs:toolkit-warning :detail "only push buttons may serve as default widgets in a dialog")
+ (return-from default-widget nil))
+ (let ((old-def-widget (default-widget self)))
+ (if old-def-widget
+ (let* ((hwnd (gfs:handle old-def-widget))
+ (style (gfs::get-window-long hwnd gfs::+gwl-style+)))
+ (setf style (logand style (lognot gfs::+bs-defpushbutton+)))
+ (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0)
+ (gfs::send-message hwnd gfs::+bm-setstyle+ style 1))))
+ (let* ((hdlg (gfs:handle self))
+ (hwnd (gfs:handle def-widget))
+ (style (gfs::get-window-long hwnd gfs::+gwl-style+)))
+ (setf style (logior style gfs::+bs-defpushbutton+))
+ (gfs::send-message hdlg gfs::+dm-setdefid+ (cffi:pointer-address hwnd) 0)
+ (gfs::send-message hdlg gfs::+wm-nextdlgctl+ (cffi:pointer-address hwnd) 1)
+ (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))
+
+(defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys)
(unless (null owner)
(if (gfs:disposed-p owner)
(error 'gfs:disposed-error)))
@@ -75,14 +115,19 @@
;;
(if (cffi:pointer-eq (gfs:handle owner) (gfs::get-desktop-window))
(setf owner nil))
- (init-window dlg +dialog-classname+ #'register-dialog-class owner text))
+ ;; 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.
+ ;;
+ (init-window self +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)))
+(defmethod show ((self dialog) flag)
+ (let* ((tc (thread-context))
+ (hutility (utility-hwnd tc))
+ (app-modal (find :application-modal (style-of self)))
+ (owner-modal (find :owner-modal (style-of self)))
+ (owner (owner self))
+ (hdlg (gfs:handle self)))
(cond
((and app-modal owner)
;; FIXME: need to save and restore each window's prior
@@ -98,7 +143,7 @@
(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)))
+ ((or (gfs:disposed-p self) (not (visible-p self)))
t) ; dialog closed, so exit loop
((zerop gm-code)
;; IMPORTANT: allow WM_QUIT to propagate back through
@@ -114,7 +159,7 @@
((= gm-code -1)
(warn 'gfs:win32-warning :detail "get-message failed")
t)
- ((/= (gfs::is-dialog-message (gfs:handle dlg) msg-ptr) 0)
+ ((/= (gfs::is-dialog-message (gfs:handle self) msg-ptr) 0)
;; It was a dialog message and has been processed,
;; so nothing else to do.
;;
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Sat May 13 19:57:06 2006
@@ -123,6 +123,9 @@
;;;
(defmethod process-message (hwnd msg wparam lparam)
+ (let ((w (get-widget (thread-context) hwnd)))
+ (if (typep w 'dialog)
+ (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam))))
(gfs::def-window-proc hwnd msg wparam lparam))
(defmethod process-message (hwnd (msg (eql gfs::+wm-close+)) wparam lparam)
@@ -139,7 +142,6 @@
(wparam-hi (hi-word wparam))
(wparam-lo (lo-word wparam))
(owner (get-widget tc hwnd)))
-(format t "wparam-hi: ~x wparam-lo: ~x lparam: ~x~%" wparam-hi wparam-lo lparam)
(if owner
(cond
((zerop lparam)
@@ -152,7 +154,7 @@
(event-time tc)
(make-instance 'gfs:rectangle)))))) ; FIXME
((eq wparam-hi 1)
- (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam))
+ (format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam)) ; FIXME: debug
(t
(let ((w (get-widget tc (cffi:make-pointer lparam))))
(if (null w)
@@ -186,8 +188,9 @@
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-create+)) wparam lparam)
- (declare (ignore wparam lparam))
- (get-widget (thread-context) hwnd) ; has side-effect of setting handle slot
+ (let ((w (get-widget (thread-context) hwnd))) ; has side-effect of setting handle slot
+ (if (typep w 'dialog)
+ (return-from process-message (gfs::def-dlg-proc hwnd msg wparam lparam))))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-destroy+)) wparam lparam)
Modified: trunk/src/uitoolkit/widgets/label.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/label.lisp (original)
+++ trunk/src/uitoolkit/widgets/label.lisp Sat May 13 19:57:06 2006
@@ -160,7 +160,8 @@
(or text " ")
(gfs:handle parent)
(logior std-style)
- ex-style)))
+ ex-style
+ (increment-widget-id (thread-context)))))
(if (not hwnd)
(error 'gfs:win32-error :detail "create-window failed"))
(setf (slot-value label 'gfs:handle) hwnd)
Modified: trunk/src/uitoolkit/widgets/panel.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/panel.lisp (original)
+++ trunk/src/uitoolkit/widgets/panel.lisp Sat May 13 19:57:06 2006
@@ -59,7 +59,7 @@
((eq sym :border)
(setf std-flags (logior std-flags gfs::+ws-border+)))))
(style-of self))
- (values std-flags 0)))
+ (values std-flags gfs::+ws-ex-controlparent+)))
(defmethod initialize-instance :after ((self panel) &key parent &allow-other-keys)
(if (null parent)
Modified: trunk/src/uitoolkit/widgets/widget-classes.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-classes.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-classes.lisp Sat May 13 19:57:06 2006
@@ -93,6 +93,12 @@
(defclass label (control) ()
(:documentation "This class represents non-selectable controls that display a string or image."))
+(defclass file-dialog (widget)
+ ((open-mode
+ :reader open-mode
+ :initform t))
+ (:documentation "This class represents the standard file open/save dialog."))
+
(defclass widget-with-items (widget)
((items
:accessor items
@@ -116,12 +122,6 @@
(defclass dialog (window) ()
(:documentation "The dialog class is the base class for both system-defined and application-defined dialogs."))
-(defclass file-dialog (dialog)
- ((open-mode
- :reader open-mode
- :initform t))
- (:documentation "This class represents the standard file open/save dialog."))
-
(defclass panel (window) ()
(:documentation "Base class for windows that are children of top-level windows (or other panels)."))
Modified: trunk/src/uitoolkit/widgets/widget-generics.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-generics.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-generics.lisp Sat May 13 19:57:06 2006
@@ -120,8 +120,8 @@
(defgeneric cut (self)
(:documentation "Copies the current selection to the clipboard and removes it from the object."))
-(defgeneric default-item (self)
- (:documentation "Returns the item in this object that has the default emphasis."))
+(defgeneric default-widget (self)
+ (:documentation "Returns the child widget or item that has the default emphasis."))
(defgeneric disabled-image (self)
(:documentation "Returns the image used to render this item with a disabled look."))
Modified: trunk/src/uitoolkit/widgets/widget-utils.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/widget-utils.lisp (original)
+++ trunk/src/uitoolkit/widgets/widget-utils.lisp Sat May 13 19:57:06 2006
@@ -82,7 +82,7 @@
ex-style
cname-ptr
title-ptr
- std-style
+ (if child-id (logior std-style gfs::+ws-tabstop+) std-style)
gfs::+cw-usedefault+
gfs::+cw-usedefault+
gfs::+cw-usedefault+
Modified: trunk/src/uitoolkit/widgets/window.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/window.lisp (original)
+++ trunk/src/uitoolkit/widgets/window.lisp Sat May 13 19:57:06 2006
@@ -145,10 +145,10 @@
(defmacro with-children ((win var) &body body)
(let ((hwnd (gensym)))
`(let ((,var nil))
- (visit-child-widgets ,win #'(lambda (parent child)
- (let ((,hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)))
- (if (cffi:pointer-eq (gfs:handle parent) ,hwnd)
- (push child ,var)))))
+ (visit-child-widgets ,win (lambda (parent child)
+ (let ((,hwnd (gfs::get-ancestor (gfs:handle child) gfs::+ga-parent+)))
+ (if (cffi:pointer-eq (gfs:handle parent) ,hwnd)
+ (push child ,var)))))
(setf ,var (reverse ,var))
,@body))))
