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))))