Author: junrue Date: Sun May 14 00:12:08 2006 New Revision: 131

Modified: trunk/docs/manual/api.texinfo trunk/src/tests/uitoolkit/layout-tester.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/control.lisp trunk/src/uitoolkit/widgets/dialog.lisp trunk/src/uitoolkit/widgets/event-source.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/widget.lisp Log: implemented :callback initarg for control initializer; got the initial focus, IDCANCEL, and IDOK button behaviors working in modal dialogs

Modified: trunk/docs/manual/api.texinfo ============================================================================== --- trunk/docs/manual/api.texinfo (original) +++ trunk/docs/manual/api.texinfo Sun May 14 00:12:08 2006 @@ -183,6 +183,14 @@ @deffn Initarg :image @end deffn @deffn Initarg :style +@table @code +@item :cancel-button +@item :check-box +@item :default-button +@item :push-button +@item :radio-button +@item :toggle-button +@end table @end deffn @deffn Initarg :text @end deffn @@ -742,6 +750,12 @@ Adds a submenu anchored to a parent menu and returns the corresponding item. @end deffn

+@deffn GenericFunction cancel-widget self +Returns the @ref{widget} that responds to the @sc{esc} key or +otherwise acts to cancel the @ref{owner}. In a @ref{dialog}, this +widget must be a @ref{button} and is typically labelled @emph{Cancel}. +@end deffn + @anchor{center-on-owner} @deffn GenericFunction center-on-owner self Position @code{self} such that it is centrally located relative to its

Modified: trunk/src/tests/uitoolkit/layout-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/layout-tester.lisp (original) +++ trunk/src/tests/uitoolkit/layout-tester.lisp Sun May 14 00:12:08 2006 @@ -92,14 +92,14 @@ (cond ((eql subtype :push-button) (setf (toggle-fn be) (let ((flag nil)) - #'(lambda () - (if (null flag) - (progn - (setf flag t) - (format nil "~d ~a" (id be) +btn-text-before+)) - (progn - (setf flag nil) - (format nil "~d ~a" (id be) +btn-text-after+)))))) + (lambda () + (if (null flag) + (progn + (setf flag t) + (format nil "~d ~a" (id be) +btn-text-before+)) + (progn + (setf flag nil) + (format nil "~d ~a" (id be) +btn-text-after+)))))) (setf (gfw:text w) (funcall (toggle-fn be)))) ((eql subtype :image-label) ;; NOTE: we are leaking a bitmap handle by not tracking the

Modified: trunk/src/tests/uitoolkit/windlg.lisp ============================================================================== --- trunk/src/tests/uitoolkit/windlg.lisp (original) +++ trunk/src/tests/uitoolkit/windlg.lisp Sun May 14 00:12:08 2006 @@ -139,12 +139,6 @@ (call-next-method) (gfs:dispose dlg))

-(defun btn-callback (disp btn time rect) - (declare (ignore disp time rect)) - (let ((dlg (gfw:parent btn))) - (gfw:show dlg nil) - (gfs:dispose dlg))) - (defun open-dlg (title style) (let* ((dlg (make-instance 'gfw:dialog :owner *main-win* :dispatcher (make-instance 'dialog-events) @@ -163,15 +157,20 @@ :style '(:vertical)) :parent dlg)) (ok-btn (make-instance 'gfw:button - :callback #'btn-callback + :callback (lambda (disp btn time rect) + (declare (ignore disp btn time rect)) + (gfs:dispose dlg)) :style '(:default-button) :text "OK" :parent btn-panel)) (cancel-btn (make-instance 'gfw:button - :callback #'btn-callback - :style '(:push-button) + :callback (lambda (disp btn time rect) + (declare (ignore disp btn time rect)) + (gfs:dispose dlg)) + :style '(:cancel-button) :text "Cancel" :parent btn-panel))) + (declare (ignore panel ok-btn cancel-btn)) (gfw:pack dlg) (gfw:center-on-owner dlg) (gfw:show dlg t)

Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Sun May 14 00:12:08 2006 @@ -832,6 +832,7 @@ (defconstant +wm-syschar+ #x0106) (defconstant +wm-sysdeadchar+ #x0107) (defconstant +wm-keylast+ #x0109) ; for use with peek-message +(defconstant +wm-initdialog+ #x0110) (defconstant +wm-command+ #x0111) (defconstant +wm-syscommand+ #x0112) (defconstant +wm-timer+ #x0113)

Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Sun May 14 00:12:08 2006 @@ -552,6 +552,11 @@ (lparam WPARAM))

(defcfun + ("SetActiveWindow" set-active-window) + HANDLE + (hwnd HANDLE)) + +(defcfun ("SetFocus" set-focus) HANDLE (hwnd HANDLE))

Modified: trunk/src/uitoolkit/widgets/button.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/button.lisp (original) +++ trunk/src/uitoolkit/widgets/button.lisp Sun May 14 00:12:08 2006 @@ -49,7 +49,7 @@ (setf std-flags (logior std-flags gfs::+bs-checkbox+))) ((eq sym :default-button) (setf std-flags (logior std-flags gfs::+bs-defpushbutton+))) - ((eq sym :push-button) + ((or (eq sym :push-button) (eq sym :cancel-button)) (setf std-flags (logior std-flags gfs::+bs-pushbutton+))) ((eq sym :radio-button) (setf std-flags (logior std-flags gfs::+bs-radiobutton+))) @@ -67,7 +67,13 @@ (gfs:handle parent) std-style ex-style - (increment-widget-id (thread-context))))) + (cond + ((find :default-button (style-of btn)) + gfs::+idok+) + ((find :cancel-button (style-of btn)) + gfs::+idcancel+) + (t + (increment-widget-id (thread-context))))))) (if (not hwnd) (error 'gfs:win32-error :detail "create-window failed")) (unless (zerop (logand std-style gfs::+bs-defpushbutton+))

Modified: trunk/src/uitoolkit/widgets/control.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/control.lisp (original) +++ trunk/src/uitoolkit/widgets/control.lisp Sun May 14 00:12:08 2006 @@ -136,9 +136,12 @@ (if (gfs:null-handle-p (gfs::set-focus (gfs:handle ctrl))) (error 'gfs:toolkit-error "set-focus failed")))

-(defmethod initialize-instance :after ((ctrl control) &key parent &allow-other-keys) +(defmethod initialize-instance :after ((ctrl control) &key callback callbacks disp parent &allow-other-keys) (if (gfs:disposed-p parent) - (error 'gfs:disposed-error))) + (error 'gfs:disposed-error)) + (unless (or disp callbacks (not (functionp callback))) + (let ((class (define-dispatcher `((event-select . ,callback))))) + (setf (dispatcher ctrl) (make-instance (class-name class))))))

(defmethod preferred-size :before ((ctrl control) width-hint height-hint) (declare (ignorable width-hint height-hint))

Modified: trunk/src/uitoolkit/widgets/dialog.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/dialog.lisp (original) +++ trunk/src/uitoolkit/widgets/dialog.lisp Sun May 14 00:12:08 2006 @@ -61,9 +61,43 @@ (values (logior gfs::+ws-caption+ gfs::+ws-popup+ gfs::+ws-sysmenu+) (logior gfs::+ws-ex-dlgmodalframe+ gfs::+ws-ex-windowedge+)))

-(defmethod event-close ((self event-dispatcher) (dlg dialog) time) - (declare (ignore time)) - (show dlg nil)) +(defmethod cancel-widget :before ((self dialog)) + (if (gfs:disposed-p self) + (error 'gfs:disposed-error))) + +(defmethod cancel-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::+idcancel+) + (setf def-widget kid)))) + def-widget)) + +(defmethod (setf cancel-widget) :before ((def-widget widget) (self dialog)) + (if (or (gfs:disposed-p self) (gfs:disposed-p def-widget)) + (error 'gfs:disposed-error))) + +(defmethod (setf cancel-widget) ((cancel-widget widget) (self dialog)) + (when (or (not (typep cancel-widget 'button)) + (and (style-of cancel-widget) + (null (intersection '(:push-button :cancel-button :default-button) + (style-of cancel-widget))))) + (warn 'gfs:toolkit-warning :detail "only push buttons may serve as cancel widgets in a dialog") + (return-from cancel-widget nil)) + (let ((old-widget (cancel-widget self))) + (if old-widget + (let* ((hwnd (gfs:handle old-widget)) + (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (setf style (logand style (lognot gfs::+bs-defpushbutton+))) + (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) + (gfs::send-message (gfs:handle self) gfs::+dm-setdefid+ 0 0) + (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))) + (let* ((hwnd (gfs:handle cancel-widget)) + (style (gfs::get-window-long hwnd gfs::+gwl-style+))) + (setf style (logior style gfs::+bs-pushbutton+)) + (gfs::set-window-long hwnd gfs::+gwlp-id+ gfs::+idcancel+) + (gfs::send-message hwnd gfs::+bm-setstyle+ style 1)))

(defmethod default-widget :before ((self dialog)) (if (gfs:disposed-p self) @@ -85,24 +119,31 @@ (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))))) + (null (intersection '(:push-button :cancel-button :default-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)) + (let ((old-widget (default-widget self))) + (if old-widget + (let* ((hwnd (gfs:handle old-widget)) (style (gfs::get-window-long hwnd gfs::+gwl-style+))) (setf style (logand style (lognot gfs::+bs-defpushbutton+))) + (gfs::set-window-long hwnd gfs::+gwlp-id+ (increment-widget-id (thread-context))) (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::set-window-long hwnd gfs::+gwlp-id+ gfs::+idok+) (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 gfs:dispose ((self dialog)) + (if (visible-p self) + (show self nil)) + (call-next-method)) + (defmethod initialize-instance :after ((self dialog) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) @@ -121,6 +162,10 @@ ;; (init-window self +dialog-classname+ #'register-dialog-class owner text))

+(defmethod event-close ((self event-dispatcher) (dlg dialog) time) + (declare (ignore time)) + (show dlg nil)) + (defmethod show ((self dialog) flag) (let* ((tc (thread-context)) (hutility (utility-hwnd tc)) @@ -139,7 +184,10 @@ (enable win (null flag)))))) ((and owner-modal owner) (enable owner (null flag)))) - (call-next-method) + (gfs::show-window hdlg (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)) + (let ((focus-hwnd (gfs::get-next-dlg-tab-item hdlg (cffi:null-pointer) 0))) + (unless (gfs:null-handle-p focus-hwnd) + (gfs::send-message hdlg gfs::+wm-nextdlgctl+ (cffi:pointer-address focus-hwnd) 1))) (when (and flag (or app-modal owner-modal)) (message-loop (lambda (gm-code msg-ptr) (cond

Modified: trunk/src/uitoolkit/widgets/event-source.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event-source.lisp (original) +++ trunk/src/uitoolkit/widgets/event-source.lisp Sun May 14 00:12:08 2006 @@ -35,7 +35,7 @@

(defconstant +callback-info+ '((gfw:event-activate . (gfw:event-source integer)) (gfw:event-arm . (gfw:event-source integer)) - (gfw:event-select . (gfw:item integer gfs:rectangle)))) + (gfw:event-select . (gfw:event-source integer gfs:rectangle))))

(defun make-specializer-list (disp-class arg-info) (let ((tmp (mapcar #'find-class arg-info))) @@ -69,8 +69,8 @@ ;;; methods ;;;

-(defmethod initialize-instance :after ((self event-source) &key callbacks &allow-other-keys) - (unless (null callbacks) +(defmethod initialize-instance :after ((self event-source) &key callbacks disp &allow-other-keys) + (unless (or disp (null callbacks)) (let ((class (define-dispatcher callbacks))) (setf (dispatcher self) (make-instance (class-name class))))))

Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Sun May 14 00:12:08 2006 @@ -167,6 +167,13 @@ (warn 'gfs:toolkit-warning :detail "no object for hwnd"))) 0)

+#| +(defmethod process-message (hwnd (msg (eql gfs::+wm-initdialog+)) wparam lparam) + (declare (ignore hwnd lparam)) + (format t "WM_INITDIALOG: ~x~%" wparam) + 1) +|# + (defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam) (declare (ignore hwnd lparam)) (let* ((tc (thread-context))

Modified: trunk/src/uitoolkit/widgets/widget.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/widget.lisp (original) +++ trunk/src/uitoolkit/widgets/widget.lisp Sun May 14 00:12:08 2006 @@ -292,8 +292,7 @@ (error 'gfs:disposed-error)))

(defmethod show ((w widget) flag) - (gfs::show-window (gfs:handle w) - (if flag gfs::+sw-showna+ gfs::+sw-hide+))) + (gfs::show-window (gfs:handle w) (if flag gfs::+sw-shownormal+ gfs::+sw-hide+)))

(defmethod update :before ((w widget)) (if (gfs:disposed-p w)