Author: junrue Date: Tue Sep 12 01:35:09 2006 New Revision: 259

Modified: trunk/docs/manual/reference.texinfo trunk/docs/manual/widget-types.texinfo trunk/src/packages.lisp trunk/src/tests/uitoolkit/event-tester.lisp trunk/src/uitoolkit/system/system-constants.lisp trunk/src/uitoolkit/system/system-types.lisp trunk/src/uitoolkit/system/user32.lisp trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/panel.lisp trunk/src/uitoolkit/widgets/top-level.lisp Log: added scroll event testing to event-tester

Modified: trunk/docs/manual/reference.texinfo ============================================================================== --- trunk/docs/manual/reference.texinfo (original) +++ trunk/docs/manual/reference.texinfo Tue Sep 12 01:35:09 2006 @@ -157,6 +157,14 @@ @end table @end macro

+@macro window-scrollbar-style{orientation,location} +@item :\orientation-scrollbar +This style keyword configures a window to have a \orientation\ +scrollbar attached on the \location. This style is a prerequisite +for scrolling functionality. The visibility policy for the scrollbar +can be configured via FIXME FIXME +@end macro + @c ==========================End Macros =============================

@copying

Modified: trunk/docs/manual/widget-types.texinfo ============================================================================== --- trunk/docs/manual/widget-types.texinfo (original) +++ trunk/docs/manual/widget-types.texinfo Tue Sep 12 01:35:09 2006 @@ -702,6 +702,14 @@ This initarg is used to specify the @ref{parent} window of the panel. @end deffn +@deffn Initarg :style +@begin-primary-style-choices{} +@item :border +This style keyword causes the panel to maintain a thin border. +@window-scrollbar-style{horizontal,bottom} +@window-scrollbar-style{vertical,right} +@end-primary-style-choices +@end deffn @end deftp

@anchor{root-window} @@ -728,10 +736,12 @@

@anchor{top-level} @deftp Class top-level -Base class for @ref{window}s that are self-contained and parented to +This class represents @ref{window}s that are self-contained and parented to the @ref{root-window}. Except when created with the @code{:borderless} or @code{:palette} styles, they are resizable and have title bars -(also called @samp{captions}). +(also called @samp{captions}). They may have scrollbars if either of the +@code{:horizontal-scrollbar} or @code{:vertical-scrollbar} styles are +specified, with further control over scrollbar visibility being possible. @deffn Initarg :maximum-size Sets the maximum @ref{size} to which the user may adjust the boundaries of the window. @@ -765,9 +775,11 @@ using the @sc{color_appworkspace} Win32 color scheme. @end-primary-style-choices @begin-optional-style-choices +@window-scrollbar-style{horizontal,bottom} @item :keyboard-navigation Enables keyboard traversal of controls within the @code{window} as if it were a @ref{dialog}. +@window-scrollbar-style{vertical,right} @end-optional-style-choices @end deffn @end deftp

Modified: trunk/src/packages.lisp ============================================================================== --- trunk/src/packages.lisp (original) +++ trunk/src/packages.lisp Tue Sep 12 01:35:09 2006 @@ -416,6 +416,7 @@ #:event-pre-move #:event-pre-resize #:event-resize + #:event-scroll #:event-select #:event-session #:event-timer

Modified: trunk/src/tests/uitoolkit/event-tester.lisp ============================================================================== --- trunk/src/tests/uitoolkit/event-tester.lisp (original) +++ trunk/src/tests/uitoolkit/event-tester.lisp Tue Sep 12 01:35:09 2006 @@ -59,6 +59,45 @@ (declare (ignore widget)) (exit-event-tester))

+(defun initialize-scrollbars () + ;; yucky test code to set scrollbar parameters -- this + ;; is not how applications will be expected to do it. + ;; + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::maxpos gfs::pagesize) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask (logior gfs::+sif-page+ gfs::+sif-range+ gfs::+sif-disablenoscroll+) + gfs::maxpos 500 + gfs::pagesize 50)) + (gfs::set-scroll-info (gfs:handle *event-tester-window*) gfs::+sb-horz+ info-ptr 0) + (gfs::set-scroll-info (gfs:handle *event-tester-window*) gfs::+sb-vert+ info-ptr 0))) + +(defun update-scrollbars (axis detail) + ;; yucky test code to set scrollbar parameters -- this + ;; is not how applications will be expected to do it. + ;; + (let ((which-sb (if (eql axis :vertical) gfs::+sb-vert+ gfs::+sb-horz+)) + (hwnd (gfs:handle *event-tester-window*))) + (cffi:with-foreign-object (info-ptr 'gfs::scrollinfo) + (gfs::zero-mem info-ptr gfs::scrollinfo) + (cffi:with-foreign-slots ((gfs::cbsize gfs::fmask gfs::pos gfs::pagesize + gfs::minpos gfs::maxpos gfs::trackpos) + info-ptr gfs::scrollinfo) + (setf gfs::cbsize (cffi:foreign-type-size 'gfs::scrollinfo) + gfs::fmask gfs::+sif-all+) + (gfs::get-scroll-info hwnd which-sb info-ptr) + (case detail + (:start (setf gfs::pos gfs::minpos)) + (:end (setf gfs::pos gfs::maxpos)) + (:step-back (setf gfs::pos (- gfs::pos 5))) + (:step-forward (setf gfs::pos (+ gfs::pos 5))) + (:page-back (setf gfs::pos (- gfs::pos gfs::pagesize))) + (:page-forward (setf gfs::pos (+ gfs::pos gfs::pagesize))) + (:thumb-track (setf gfs::pos gfs::trackpos))) + (gfs::set-scroll-info hwnd which-sb info-ptr 1))))) + (defun text-for-modifiers () (format nil "~:[SHIFT~;~] ~:[CTRL~;~] ~:[ALT~;~] ~:[L-WIN~;~] ~:[R-WIN~;~] ~:[ESC~;~] ~:[CAPSLOCK~;~] ~:[NUMLOCK~;~] ~:[SCROLLOCK~;~]" @@ -137,6 +176,15 @@ (gfw:obtain-event-time) (text-for-modifiers)))

+(defun text-for-scroll (axis detail) + (format nil + "~a scroll: ~s detail: ~s time: 0x~x ~s" + (incf *event-counter*) + axis + detail + (gfw:obtain-event-time) + (text-for-modifiers))) + (defmethod gfw:event-activate ((d event-tester-window-events) window) (setf *event-tester-text* (text-for-activation "window activated")) (gfw:redraw window)) @@ -174,13 +222,16 @@

(defmethod gfw:event-move ((d event-tester-window-events) window pnt) (setf *event-tester-text* (text-for-move pnt)) - (gfw:redraw window) - 0) + (gfw:redraw window))

(defmethod gfw:event-resize ((d event-tester-window-events) window size type) (setf *event-tester-text* (text-for-size type size)) - (gfw:redraw window) - 0) + (gfw:redraw window)) + +(defmethod gfw:event-scroll ((d event-tester-window-events) window axis detail) + (update-scrollbars axis detail) + (setf *event-tester-text* (text-for-scroll axis detail)) + (gfw:redraw window))

(defclass event-tester-exit-dispatcher (gfw:event-dispatcher) ())

@@ -240,7 +291,8 @@ (exit-md (make-instance 'event-tester-exit-dispatcher)) (menubar nil)) (setf *event-tester-window* (make-instance 'gfw:top-level :dispatcher (make-instance 'event-tester-window-events) - :style '(:workspace))) + :style '(:workspace :horizontal-scrollbar :vertical-scrollbar))) + (initialize-scrollbars) (setf menubar (gfw:defmenu ((:item "&File" :callback #'manage-file-menu :submenu ((:item "Timer" :callback #'manage-timer) (:item "" :separator)

Modified: trunk/src/uitoolkit/system/system-constants.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-constants.lisp (original) +++ trunk/src/uitoolkit/system/system-constants.lisp Tue Sep 12 01:35:09 2006 @@ -834,6 +834,11 @@ (defconstant +ps-geometric+ #x00010000) (defconstant +ps-type-mask+ #x000f0000)

+(defconstant +sb-horz+ 0) +(defconstant +sb-vert+ 1) +(defconstant +sb-ctl+ 2) +(defconstant +sb-both+ 3) + (defconstant +sb-lineup+ 0) (defconstant +sb-lineleft+ 0) (defconstant +sb-linedown+ 1) @@ -850,6 +855,13 @@ (defconstant +sb-right+ 7) (defconstant +sb-endscroll+ 8)

+(defconstant +sif-range+ #x0001) +(defconstant +sif-page+ #x0002) +(defconstant +sif-pos+ #x0004) +(defconstant +sif-disablenoscroll+ #x0008) +(defconstant +sif-trackpos+ #x0010) +(defconstant +sif-all+ #x0017) + (defconstant +size-restored+ 0) (defconstant +size-minimized+ 1) (defconstant +size-maximized+ 2)

Modified: trunk/src/uitoolkit/system/system-types.lisp ============================================================================== --- trunk/src/uitoolkit/system/system-types.lisp (original) +++ trunk/src/uitoolkit/system/system-types.lisp Tue Sep 12 01:35:09 2006 @@ -329,6 +329,15 @@ (rgbred BYTE) (rgbreserved BYTE))

+(defcstruct scrollinfo + (cbsize UINT) + (fmask UINT) + (minpos INT) + (maxpos INT) + (pagesize UINT) + (pos INT) + (trackpos INT)) + (defcstruct size (cx LONG) (cy LONG))

Modified: trunk/src/uitoolkit/system/user32.lisp ============================================================================== --- trunk/src/uitoolkit/system/user32.lisp (original) +++ trunk/src/uitoolkit/system/user32.lisp Tue Sep 12 01:35:09 2006 @@ -436,6 +436,13 @@ (hwnd HANDLE))

(defcfun + ("GetScrollInfo" get-scroll-info) + BOOL + (hwnd HANDLE) + (bar INT) + (info LPTR)) + +(defcfun ("GetSubMenu" get-submenu) HANDLE (hwnd HANDLE) @@ -667,6 +674,14 @@ (item-info LPTR))

(defcfun + ("SetScrollInfo" set-scroll-info) + INT + (hwnd HANDLE) + (bar INT) + (info LPTR) + (redraw BOOL)) + +(defcfun ("SetTimer" set-timer) UINT (hwnd HANDLE)

Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Tue Sep 12 01:35:09 2006 @@ -143,9 +143,9 @@ (setf ret-val (cffi:pointer-address (brush-handle-of widget)))) ret-val))

-(defun dispatch-scroll-notification (widget axis wparam-hi) +(defun dispatch-scroll-notification (widget axis wparam-lo) (let ((disp (dispatcher widget))) - (case wparam-hi + (case wparam-lo (#.gfs::+sb-top+ (event-scroll disp widget axis :start)) ; (#.gfs::+sb-left+ (event-scroll disp widget axis :start)) (#.gfs::+sb-bottom+ (event-scroll disp widget axis :end)) @@ -351,14 +351,14 @@ (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (dispatch-scroll-notification widget :horizontal (hi-word wparam)))) + (dispatch-scroll-notification widget :horizontal (lo-word wparam)))) 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-vscroll+)) wparam lparam) (declare (ignore lparam)) (let ((widget (get-widget (thread-context) hwnd))) (if widget - (dispatch-scroll-notification widget :vertical (hi-word wparam)))) + (dispatch-scroll-notification widget :vertical (lo-word wparam)))) 0)

(defmethod process-message (hwnd (msg (eql gfs::+wm-paint+)) wparam lparam)

Modified: trunk/src/uitoolkit/widgets/panel.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/panel.lisp (original) +++ trunk/src/uitoolkit/widgets/panel.lisp Tue Sep 12 01:35:09 2006 @@ -56,13 +56,16 @@ (defmethod compute-style-flags ((self panel) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags +default-child-style+)) - (mapc #'(lambda (sym) - (cond + (loop for sym in (style-of self) + do (ecase sym ;; styles that can be combined ;; - ((eq sym :border) - (setf std-flags (logior std-flags gfs::+ws-border+))))) - (style-of self)) + (:border + (setf std-flags (logior std-flags gfs::+ws-border+))) + (:horizontal-scrollbar + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:vertical-scrollbar + (setf std-flags (logior std-flags gfs::+ws-vscroll+))))) (values std-flags gfs::+ws-ex-controlparent+)))

(defmethod initialize-instance :after ((self panel) &key parent &allow-other-keys)

Modified: trunk/src/uitoolkit/widgets/top-level.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/top-level.lisp (original) +++ trunk/src/uitoolkit/widgets/top-level.lisp Tue Sep 12 01:35:09 2006 @@ -68,47 +68,28 @@ ;;; methods ;;;

-(defmethod compute-style-flags ((win top-level) &rest extra-data) +(defmethod compute-style-flags ((self top-level) &rest extra-data) (declare (ignore extra-data)) (let ((std-flags 0) (ex-flags 0)) - (mapc #'(lambda (sym) - (cond - ;; styles that can be combined - ;; -#| - ((eq sym :hscroll) - (setf std-flags (logior std-flags gfs::+ws-hscroll+))) - ((eq sym :max) - (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) - ((eq sym :min) - (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) - ((eq sym :sysmenu) - (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) - ((eq sym :title) - (setf std-flags (logior std-flags gfs::+ws-caption+))) - ((eq sym :top) - (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) - ((eq sym :vscroll) - (setf std-flags (logior std-flags gfs::+ws-vscroll+))) -|# - - ;; pre-packaged combinations of window styles - ;; - ((eq sym :borderless) + (loop for sym in (style-of self) + do (ecase sym + ;; pre-packaged combinations of window styles + ;; + (:borderless (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-border+ gfs::+ws-popup+)) (setf ex-flags gfs::+ws-ex-topmost+)) - ((eq sym :palette) + (:palette (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popupwindow+ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-toolwindow+ gfs::+ws-ex-windowedge+))) - ((eq sym :miniframe) + (:miniframe (setf std-flags (logior gfs::+ws-clipchildren+ gfs::+ws-clipsiblings+ gfs::+ws-popup+ @@ -117,22 +98,40 @@ gfs::+ws-caption+)) (setf ex-flags (logior gfs::+ws-ex-appwindow+ gfs::+ws-ex-toolwindow+))) - ((or (eq sym :workspace) (eq sym :frame)) + (:frame + (setf std-flags (logior gfs::+ws-overlappedwindow+ + gfs::+ws-clipsiblings+ + gfs::+ws-clipchildren+)) + (setf ex-flags 0)) + (:workspace (setf std-flags (logior gfs::+ws-overlappedwindow+ gfs::+ws-clipsiblings+ gfs::+ws-clipchildren+)) - (setf ex-flags 0)))) - (style-of win)) + (setf ex-flags 0)) + + ;; styles that can be combined + ;; +#| + (:max (setf std-flags (logior std-flags gfs::+ws-maximizebox+))) + (:min (setf std-flags (logior std-flags gfs::+ws-minimizebox+))) + (:sysmenu (setf std-flags (logior std-flags gfs::+ws-sysmenu+))) + (:title (setf std-flags (logior std-flags gfs::+ws-caption+))) + (:top (setf ex-flags (logior ex-flags gfs::+ws-ex-topmost+))) +|# + (:horizontal-scrollbar + (setf std-flags (logior std-flags gfs::+ws-hscroll+))) + (:vertical-scrollbar + (setf std-flags (logior std-flags gfs::+ws-vscroll+))))) (values std-flags ex-flags)))

-(defmethod gfs:dispose ((win top-level)) - (let ((m (menu-bar win))) +(defmethod gfs:dispose ((self top-level)) + (let ((m (menu-bar self))) (unless (null m) (visit-menu-tree m #'menu-cleanup-callback) (delete-widget (thread-context) (gfs:handle m)))) (call-next-method))

-(defmethod initialize-instance :after ((win top-level) &key owner text &allow-other-keys) +(defmethod initialize-instance :after ((self top-level) &key owner text &allow-other-keys) (unless (null owner) (if (gfs:disposed-p owner) (error 'gfs:disposed-error))) @@ -140,21 +139,21 @@ (setf text *default-window-title*)) (let ((classname *toplevel-noerasebkgnd-window-classname*) (register-func #'register-toplevel-noerasebkgnd-window-class)) - (when (find :workspace (style-of win)) + (when (find :workspace (style-of self)) (setf classname *toplevel-erasebkgnd-window-classname*) (setf register-func #'register-toplevel-erasebkgnd-window-class)) - (init-window win classname register-func owner text))) + (init-window self classname register-func owner text)))

(defmethod (setf maximum-size) :after (max-size (self top-level)) (when (and max-size (minimum-size self)) (update-top-level-resizability self (gfs:equal-size-p (minimum-size self) max-size))))

-(defmethod menu-bar :before ((win top-level)) - (if (gfs:disposed-p win) +(defmethod menu-bar :before ((self top-level)) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

-(defmethod menu-bar ((win top-level)) - (let ((hmenu (gfs::get-menu (gfs:handle win)))) +(defmethod menu-bar ((self top-level)) + (let ((hmenu (gfs::get-menu (gfs:handle self)))) (if (gfs:null-handle-p hmenu) (return-from menu-bar nil)) (let ((m (get-widget (thread-context) hmenu))) @@ -162,13 +161,13 @@ (error 'gfs:toolkit-error :detail "no object for menu handle")) m)))

-(defmethod (setf menu-bar) :before ((m menu) (win top-level)) +(defmethod (setf menu-bar) :before ((m menu) (self top-level)) (declare (ignore m)) - (if (gfs:disposed-p win) + (if (gfs:disposed-p self) (error 'gfs:disposed-error)))

-(defmethod (setf menu-bar) ((m menu) (win top-level)) - (let* ((hwnd (gfs:handle win)) +(defmethod (setf menu-bar) ((m menu) (self top-level)) + (let* ((hwnd (gfs:handle self)) (hmenu (gfs::get-menu hwnd)) (old-menu (get-widget (thread-context) hmenu))) (unless (gfs:null-handle-p hmenu)