[graphic-forms-cvs] r131 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sun May 14 04:12:13 UTC 2006
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
+ at table @code
+ at item :cancel-button
+ at item :check-box
+ at item :default-button
+ at item :push-button
+ at item :radio-button
+ at item :toggle-button
+ at 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
+ at 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}.
+ at 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)
More information about the Graphic-forms-cvs
mailing list