Author: junrue Date: Thu Sep 21 16:58:29 2006 New Revision: 262 Added: trunk/src/tests/uitoolkit/scroll-tester.lisp Modified: trunk/docs/manual/widget-functions.texinfo trunk/graphic-forms-tests.asd trunk/src/uitoolkit/widgets/event.lisp trunk/src/uitoolkit/widgets/window.lisp Log: fixed a silly WM_PAINT handling bug in initializing the paint rect; small improvement to window print-object; other miscellaneous tweaks Modified: trunk/docs/manual/widget-functions.texinfo ============================================================================== --- trunk/docs/manual/widget-functions.texinfo (original) +++ trunk/docs/manual/widget-functions.texinfo Thu Sep 21 16:58:29 2006 @@ -271,7 +271,8 @@ @anchor{horizontal-scrollbar-p} @deffn GenericFunction horizontal-scrollbar-p self => boolean Returns T if @var{self} has been configured to display a horizontal -scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. +scrollbar, even if said scrollbar is not currently visible; or +returns @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @deffn GenericFunction image self => @ref{image} @@ -386,6 +387,32 @@ of these is the primary @ref{display}. @end defun +@anchor{obtain-horizontal-scrollbar} +@deffn GenericFunction obtain-horizontal-scrollbar self => widget +Returns a @ref{widget} representing the horizontal scrollbar attached +to the bottom of @var{self}, if @var{self} is configured to have one +and whether or not said scrollbar is currently visible; or returns +@sc{nil} if @var{self} is not configured to have a horizontal scrollbar. +Note that the widget returned by this function is not a @ref{control} +instance; it is instead an abstract of what is referred to in the Microsoft +documentation as a @emph{standard scrollbar}. + +See also @ref{obtain-vertical-scrollbar} and @ref{horizontal-scrollbar-p}. +@end deffn + +@anchor{obtain-vertical-scrollbar} +@deffn GenericFunction obtain-vertical-scrollbar self => widget +Returns a @ref{widget} representing the vertical scrollbar attached +to the right side of @var{self}, if @var{self} is configured to have one +and whether or not said scrollbar is currently visible; or returns +@sc{nil} if @var{self} is not configured to have a vertical scrollbar. +Note that the widget returned by this function is not a @ref{control} +instance; it is instead an abstract of what is referred to in the Microsoft +documentation as a @emph{standard scrollbar}. + +See also @ref{obtain-horizontal-scrollbar} and @ref{vertical-scrollbar-p}. +@end deffn + @anchor{obtain-primary-display} @defun obtain-primary-display => @ref{display} Return a display object that is regarded by the system as @@ -638,7 +665,8 @@ @anchor{vertical-scrollbar-p} @deffn GenericFunction vertical-scrollbar-p self => boolean Returns T if @var{self} has been configured to display a vertical -scrollbar; @sc{nil} otherwise. @xref{enable-scrollbars}. +scrollbar, even if said scrollbar is not currently visible; or +returns @sc{nil} otherwise. @xref{enable-scrollbars}. @end deffn @deffn GenericFunction visible-p self Modified: trunk/graphic-forms-tests.asd ============================================================================== --- trunk/graphic-forms-tests.asd (original) +++ trunk/graphic-forms-tests.asd Thu Sep 21 16:58:29 2006 @@ -42,6 +42,7 @@ #:hello-world #:image-tester #:layout-tester + #:scroll-tester #:widget-tester #:textedit #:unblocked @@ -89,4 +90,5 @@ (:file "image-tester") (:file "drawing-tester") (:file "widget-tester") + (:file "scroll-tester") (:file "windlg"))))))))) Added: trunk/src/tests/uitoolkit/scroll-tester.lisp ============================================================================== --- (empty file) +++ trunk/src/tests/uitoolkit/scroll-tester.lisp Thu Sep 21 16:58:29 2006 @@ -0,0 +1,80 @@ +;;;; +;;;; scroll-tester.lisp +;;;; +;;;; Copyright (C) 2006, Jack D. Unrue +;;;; All rights reserved. +;;;; +;;;; Redistribution and use in source and binary forms, with or without +;;;; modification, are permitted provided that the following conditions +;;;; are met: +;;;; +;;;; 1. Redistributions of source code must retain the above copyright +;;;; notice, this list of conditions and the following disclaimer. +;;;; +;;;; 2. Redistributions in binary form must reproduce the above copyright +;;;; notice, this list of conditions and the following disclaimer in the +;;;; documentation and/or other materials provided with the distribution. +;;;; +;;;; 3. Neither the names of the authors nor the names of its contributors +;;;; may be used to endorse or promote products derived from this software +;;;; without specific prior written permission. +;;;; +;;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS AND CONTRIBUTORS "AS IS" AND ANY +;;;; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DIS- +;;;; CLAIMED. IN NO EVENT SHALL THE AUTHORS AND CONTRIBUTORS BE LIABLE FOR ANY +;;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +;;;; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +;;;; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +;;;; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +;;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;;;; + +(in-package #:graphic-forms.uitoolkit.tests) + +(defvar *scroll-tester-win* nil) + +(defun scroll-tester-exit (disp item) + (declare (ignore disp item)) + (gfs:dispose *scroll-tester-win*) + (setf *scroll-tester-win* nil) + (gfw:shutdown 0)) + +(defclass scroll-tester-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-close ((disp scroll-tester-events) window) + (declare (ignore window)) + (scroll-tester-exit disp nil)) + +(defclass scroll-panel-events (gfw:event-dispatcher) ()) + +(defmethod gfw:event-paint ((disp scroll-panel-events) window gc rect) + (let ((color (gfg:rgb->color (gfs::get-sys-color gfs::+color-btnface+)))) + (setf (gfg:background-color gc) color + (gfg:foreground-color gc) color)) + (gfg:draw-filled-rectangle gc rect)) + +(defun scroll-tester-internal () + (setf *default-pathname-defaults* (parse-namestring gfsys::*gf-tests-dir*)) + (let ((disp (make-instance 'scroll-tester-events)) + (panel-disp (make-instance 'scroll-panel-events)) + (layout (make-instance 'gfw:heap-layout)) + (menubar (gfw:defmenu ((:item "&File" + :submenu ((:item "E&xit" :callback #'scroll-tester-exit))))))) + (setf *scroll-tester-win* (make-instance 'gfw:top-level :dispatcher disp + :layout layout + :style '(:frame))) + (let ((icons (make-instance 'gfg:icon-bundle :file (merge-pathnames "default.ico"))) + (panel (make-instance 'gfw:panel :dispatcher panel-disp + :parent *scroll-tester-win*)) + (panel-size (gfs:make-size :width 200 :height 200))) + (setf (gfw:minimum-size panel) panel-size + (gfw:maximum-size panel) panel-size + (gfw:menu-bar *scroll-tester-win*) menubar + (gfw:top-child-of layout) panel + (gfw:image *scroll-tester-win*) icons)) + (gfw:show *scroll-tester-win* t))) + +(defun scroll-tester () + (gfw:startup "Scroll Tester" #'scroll-tester-internal)) Modified: trunk/src/uitoolkit/widgets/event.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/event.lisp (original) +++ trunk/src/uitoolkit/widgets/event.lisp Thu Sep 21 16:58:29 2006 @@ -372,11 +372,11 @@ gfs::rcpaint-width gfs::rcpaint-height) ps-ptr gfs::paintstruct) - (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x - :y gfs::rcpaint-y)) - (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width - :height gfs::rcpaint-height)) (let ((gc (make-instance 'gfg:graphics-context :handle (gfs::begin-paint hwnd ps-ptr)))) + (setf (gfs:location rct) (gfs:make-point :x gfs::rcpaint-x + :y gfs::rcpaint-y)) + (setf (gfs:size rct) (gfs:make-size :width gfs::rcpaint-width + :height gfs::rcpaint-height)) (unwind-protect (event-paint (dispatcher widget) widget gc rct) (gfs:dispose gc) Modified: trunk/src/uitoolkit/widgets/window.lisp ============================================================================== --- trunk/src/uitoolkit/widgets/window.lisp (original) +++ trunk/src/uitoolkit/widgets/window.lisp Thu Sep 21 16:58:29 2006 @@ -193,12 +193,6 @@ (let ((sz (client-size self))) (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) -(defmethod event-resize ((disp event-dispatcher) (self window) size type) - (declare (ignore size type)) - (unless (null (layout-of self)) - (let ((sz (client-size self))) - (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) - (defmethod enable-scrollbars ((self window) horizontal vertical) (let ((bits (get-native-style self))) (if horizontal @@ -209,6 +203,12 @@ (setf bits (logand bits (lognot gfs::+ws-vscroll+)))) (update-native-style self bits))) +(defmethod event-resize ((disp event-dispatcher) (self window) size type) + (declare (ignore size type)) + (unless (null (layout-of self)) + (let ((sz (client-size self))) + (perform (layout-of self) self (gfs:size-width sz) (gfs:size-height sz))))) + (defmethod focus-p :before ((self window)) (if (gfs:disposed-p self) (error 'gfs:disposed-error))) @@ -326,7 +326,8 @@ (print-unreadable-object (self stream :type t) (format stream "handle: ~x " (gfs:handle self)) (format stream "dispatcher: ~a " (dispatcher self)) - (format stream "size: ~a" (size self)))) + (if (not (gfs:disposed-p self)) + (format stream "size: ~a" (size self))))) (defmethod show ((self window) flag) (declare (ignore flag))