[graphic-forms-cvs] r259 - in trunk: docs/manual src src/tests/uitoolkit src/uitoolkit/system src/uitoolkit/widgets
junrue at common-lisp.net
junrue at common-lisp.net
Tue Sep 12 05:35:13 UTC 2006
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
+ at macro window-scrollbar-style{orientation,location}
+ at 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
+ at 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
+ at deffn Initarg :style
+ at begin-primary-style-choices{}
+ at item :border
+This style keyword causes the panel to maintain a thin border.
+ at window-scrollbar-style{horizontal,bottom}
+ at window-scrollbar-style{vertical,right}
+ at end-primary-style-choices
+ at 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
+ at 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
+ at window-scrollbar-style{horizontal,bottom}
@item :keyboard-navigation
Enables keyboard traversal of controls within the @code{window} as if
it were a @ref{dialog}.
+ at 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)
More information about the Graphic-forms-cvs
mailing list