[graphic-forms-cvs] r129 - in trunk: docs/manual src/tests/uitoolkit src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Sat May 13 16:51:00 UTC 2006
Author: junrue
Date: Sat May 13 12:50:58 2006
New Revision: 129
Modified:
trunk/docs/manual/api.texinfo
trunk/src/tests/uitoolkit/windlg.lisp
trunk/src/uitoolkit/widgets/button.lisp
trunk/src/uitoolkit/widgets/event.lisp
trunk/src/uitoolkit/widgets/thread-context.lisp
trunk/src/uitoolkit/widgets/timer.lisp
trunk/src/uitoolkit/widgets/widget-utils.lisp
Log:
implement :text initarg for buttons; generalize timer id counter in thread-context to all widgets except menu items; specify a runtime-unique ID for every widget; assorted bug fixes for WM_COMMAND process-message
Modified: trunk/docs/manual/api.texinfo
==============================================================================
--- trunk/docs/manual/api.texinfo (original)
+++ trunk/docs/manual/api.texinfo Sat May 13 12:50:58 2006
@@ -175,9 +175,17 @@
@strong{NOTE:} A future release will provide additional widget
classes.
+ at anchor{button}
@deftp Class button
This @ref{control} class represents selectable controls that issue
-notifications when clicked.
+notifications when clicked.@*@*
+The following initargs are supported:
+ at deffn Initarg :image
+ at end deffn
+ at deffn Initarg :style
+ at end deffn
+ at deffn Initarg :text
+ at end deffn
@end deftp
@anchor{control}
@@ -711,10 +719,6 @@
@node widget functions
@section widget functions
- at strong{NOTE:} There are (and will be) additional widget methods defined
-in future releases, they just aren't all documented or implemented at
-this time.
-
@deffn GenericFunction ancestor-p ancestor descendant
Returns T if ancestor is an ancestor of descendant; nil otherwise.
@end deffn
@@ -779,6 +783,13 @@
enclose the specified desired client area and this object's trim.
@end deffn
+ at 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
+ at code{self} is active and the user presses @sc{enter}.
+ at end deffn
+
@deffn GenericFunction display-to-object self pnt
Return a point that is the result of transforming the specified point
from display-relative coordinates to this object's coordinate system.
Modified: trunk/src/tests/uitoolkit/windlg.lisp
==============================================================================
--- trunk/src/tests/uitoolkit/windlg.lisp (original)
+++ trunk/src/tests/uitoolkit/windlg.lisp Sat May 13 12:50:58 2006
@@ -139,6 +139,12 @@
(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)
@@ -151,14 +157,20 @@
(panel (make-instance 'dlg-test-panel
:style '(:border)
:parent dlg))
- (btn (make-instance 'gfw:button
- :callback (lambda (disp btn time rect)
- (declare (ignore disp time rect))
- (let ((dlg (gfw:parent btn)))
- (gfw:show dlg nil)
- (gfs:dispose dlg)))
- :parent dlg)))
- (setf (gfw:text btn) "Close")
+ (btn-panel (make-instance 'gfw:panel
+ :layout (make-instance 'gfw:flow-layout
+ :spacing 4
+ :style '(:vertical))
+ :parent dlg))
+ (ok-btn (make-instance 'gfw:button
+ :callback #'btn-callback
+ :text "OK"
+ :parent btn-panel))
+ (cancel-btn (make-instance 'gfw:button
+ :callback #'btn-callback
+ :style '(:push-button)
+ :text "Cancel"
+ :parent btn-panel)))
(gfw:pack dlg)
(gfw:center-on-owner dlg)
(gfw:show dlg t)
Modified: trunk/src/uitoolkit/widgets/button.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/button.lisp (original)
+++ trunk/src/uitoolkit/widgets/button.lisp Sat May 13 12:50:58 2006
@@ -40,9 +40,6 @@
(defmethod compute-style-flags ((btn button) &rest extra-data)
(declare (ignore extra-data))
(let ((std-flags (logior gfs::+ws-child+ gfs::+ws-visible+)))
- ;; FIXME: check whether any of the primary button
- ;; styles were specified, default to :push-button
- ;;
(loop for sym in (style-of btn)
do (cond
;; primary button styles
@@ -59,11 +56,11 @@
(setf std-flags (logior std-flags gfs::+bs-pushbox+)))))
(values std-flags 0)))
-(defmethod initialize-instance :after ((btn button) &key parent &allow-other-keys)
+(defmethod initialize-instance :after ((btn button) &key parent text &allow-other-keys)
(multiple-value-bind (std-style ex-style)
(compute-style-flags btn)
(let ((hwnd (create-window gfs::+button-classname+
- " "
+ (or text " ")
(gfs:handle parent)
std-style
ex-style)))
Modified: trunk/src/uitoolkit/widgets/event.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/event.lisp (original)
+++ trunk/src/uitoolkit/widgets/event.lisp Sat May 13 12:50:58 2006
@@ -137,30 +137,32 @@
(defmethod process-message (hwnd (msg (eql gfs::+wm-command+)) wparam lparam)
(let* ((tc (thread-context))
(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)
- (let ((item (get-menuitem tc (lo-word wparam))))
+ (let ((item (get-menuitem tc wparam-lo)))
(if (null item)
- (error 'gfs:toolkit-error :detail "no menu item for id"))
- (unless (null (dispatcher item))
- (event-select (dispatcher item)
- item
- (event-time tc)
- (make-instance 'gfs:rectangle))))) ; FIXME
+ (warn 'gfs:toolkit-warning :detail (format nil "no menu item for id ~x" wparam-lo))
+ (unless (null (dispatcher item))
+ (event-select (dispatcher item)
+ item
+ (event-time tc)
+ (make-instance 'gfs:rectangle)))))) ; FIXME
((eq wparam-hi 1)
(format t "accelerator wparam: ~x lparam: ~x~%" wparam lparam))
(t
(let ((w (get-widget tc (cffi:make-pointer lparam))))
(if (null w)
- (error 'gfs:toolkit-error :detail "no object for hwnd"))
- (unless (null (dispatcher w))
- (event-select (dispatcher w)
- w
- (event-time tc)
- (make-instance 'gfs:rectangle)))))) ; FIXME
- (error 'gfs:toolkit-error :detail "no object for hwnd")))
+ (warn 'gfs:toolkit-warning :detail "no object for hwnd")
+ (unless (null (dispatcher w))
+ (event-select (dispatcher w)
+ w
+ (event-time tc)
+ (make-instance 'gfs:rectangle))))))) ; FIXME
+ (warn 'gfs:toolkit-warning :detail "no object for hwnd")))
0)
(defmethod process-message (hwnd (msg (eql gfs::+wm-initmenupopup+)) wparam lparam)
Modified: trunk/src/uitoolkit/widgets/thread-context.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/thread-context.lisp (original)
+++ trunk/src/uitoolkit/widgets/thread-context.lisp Sat May 13 12:50:58 2006
@@ -45,7 +45,7 @@
(mouse-event-pnt :initform (gfs:make-point) :accessor mouse-event-pnt)
(move-event-pnt :initform (gfs:make-point) :accessor move-event-pnt)
(next-menuitem-id :initform 10000 :reader next-menuitem-id)
- (next-timer-id :initform 1 :reader next-timer-id)
+ (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))
(timers-by-id :initform (make-hash-table :test #'equal))
@@ -198,8 +198,8 @@
(remhash k (slot-value tc 'timers-by-id))))
(slot-value tc 'timers-by-id)))
-(defmethod increment-timer-id ((tc thread-context))
+(defmethod increment-widget-id ((tc thread-context))
"Return the next timer ID; also increment the internal value."
- (let ((id (next-timer-id tc)))
- (incf (slot-value tc 'next-timer-id))
+ (let ((id (next-widget-id tc)))
+ (incf (slot-value tc 'next-widget-id))
id))
Modified: trunk/src/uitoolkit/widgets/timer.lisp
==============================================================================
--- trunk/src/uitoolkit/widgets/timer.lisp (original)
+++ trunk/src/uitoolkit/widgets/timer.lisp Sat May 13 12:50:58 2006
@@ -63,7 +63,7 @@
(let ((tc (thread-context))
(id (id-of timer)))
(when (zerop id)
- (setf (slot-value timer 'id) (increment-timer-id tc))
+ (setf (slot-value timer 'id) (increment-widget-id tc))
(put-timer tc timer))
(if (zerop (gfs::set-timer (utility-hwnd tc) (id-of timer) clamped (cffi:null-pointer)))
(error 'gfs:win32-error :detail "set-timer failed")))
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 12:50:58 2006
@@ -75,7 +75,7 @@
(unless (zerop count)
(gfw:clear-span w (gfs:make-span :start 0 :end (1- count))))))
-(defun create-window (class-name title parent-hwnd std-style ex-style)
+(defun create-window (class-name title parent-hwnd std-style ex-style &optional child-id)
(cffi:with-foreign-string (cname-ptr class-name)
(cffi:with-foreign-string (title-ptr title)
(gfs::create-window
@@ -88,7 +88,9 @@
gfs::+cw-usedefault+
gfs::+cw-usedefault+
parent-hwnd
- (cffi:null-pointer)
+ (if (zerop (logand gfs::+ws-child+ std-style))
+ (cffi:null-pointer)
+ (cffi:make-pointer (or child-id (increment-widget-id (thread-context)))))
(cffi:null-pointer)
0))))
More information about the Graphic-forms-cvs
mailing list