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.
+@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: +@deffn Initarg :image +@end deffn +@deffn Initarg :style +@end deffn +@deffn Initarg :text +@end deffn @end deftp
@anchor{control} @@ -711,10 +719,6 @@ @node widget functions @section widget functions
-@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
+@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}. +@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))))