From 0e2b88e51a3f66e43fd65483833d75e5137f4b6c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 12 Aug 2012 19:08:17 -0600 Subject: [PATCH] racket/gui: fix access of scrollbar values for canvas without a scrollbar original commit: 1800680c6ba0dec0f8b2f7d0495c615906b27b47 --- collects/mred/private/wx/cocoa/canvas.rkt | 24 ++++++++++++------- .../mred/private/wx/common/canvas-mixin.rkt | 3 +++ collects/mred/private/wx/gtk/canvas.rkt | 15 ++++++++---- collects/mred/private/wx/win32/canvas.rkt | 17 +++++++++---- collects/tests/gracket/windowing.rktl | 17 ++++++++++++- 5 files changed, 58 insertions(+), 18 deletions(-) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index 246863a9..f18b11c9 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -233,7 +233,8 @@ get-size get-position set-focus client-to-screen - is-auto-scroll? get-virtual-width get-virtual-height + is-auto-scroll? is-disabled-scroll? + get-virtual-width get-virtual-height reset-auto-scroll refresh-for-autoscroll refresh-all-children @@ -521,25 +522,32 @@ (define/public (set-scroll-pos which v) (update which scroll-pos v)) - (define/private (guard-scroll skip-guard? which v) + (define/private (guard-scroll skip-guard? which get-v) (if skip-guard? - v - (if (is-auto-scroll?) + (get-v) + (if (or (if (eq? which 'vertical) + (not vscroll-ok?) + (not hscroll-ok?)) + (is-disabled-scroll?) + (is-auto-scroll?)) 0 - v))) + (get-v)))) (define/public (get-scroll-page which [skip-guard? #f]) (guard-scroll skip-guard? which - (scroll-page (if (eq? which 'vertical) v-scroller h-scroller)))) + (lambda () + (scroll-page (if (eq? which 'vertical) v-scroller h-scroller))))) (define/public (get-scroll-range which [skip-guard? #f]) (guard-scroll skip-guard? which - (scroll-range (if (eq? which 'vertical) v-scroller h-scroller)))) + (lambda () + (scroll-range (if (eq? which 'vertical) v-scroller h-scroller))))) (define/public (get-scroll-pos which [skip-guard? #f]) (guard-scroll skip-guard? which - (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller)))) + (lambda () + (scroll-pos (if (eq? which 'vertical) v-scroller h-scroller))))) (define v-scroller (and vscroll-ok? diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index cc2a3992..9be983b8 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -18,11 +18,13 @@ (inherit get-client-size refresh) + (define any-scroll? #f) (define auto-scroll? #f) (define virtual-height #f) (define virtual-width #f) (define/public (is-auto-scroll?) auto-scroll?) + (define/public (is-disabled-scroll?) (not any-scroll?)) (define/public (get-virtual-height) virtual-height) (define/public (get-virtual-width) virtual-width) @@ -31,6 +33,7 @@ h-page v-page h-pos v-pos auto?) + (set! any-scroll? #t) (cond [auto? (set! auto-scroll? #t) diff --git a/collects/mred/private/wx/gtk/canvas.rkt b/collects/mred/private/wx/gtk/canvas.rkt index e13660d0..1e6c5e12 100644 --- a/collects/mred/private/wx/gtk/canvas.rkt +++ b/collects/mred/private/wx/gtk/canvas.rkt @@ -239,7 +239,8 @@ get-top-win set-auto-size adjust-client-delta infer-client-delta - is-auto-scroll? get-virtual-width get-virtual-height + is-auto-scroll? is-disabled-scroll? + get-virtual-width get-virtual-height refresh-for-autoscroll refresh-all-children get-eventspace) @@ -609,19 +610,25 @@ (lambda () (gtk_adjustment_set_value adj v)))))) + (define/private (is-disabled-scroll-dir? which) + (or (if (eq? which 'vertical) + (not vscroll-gtk) + (not hscroll-gtk)) + (is-disabled-scroll?))) + (define/public (get-scroll-page which) - (if (is-auto-scroll?) + (if (or (is-disabled-scroll-dir? which) (is-auto-scroll?)) 0 (->long (dispatch which gtk_adjustment_get_page_size 0)))) (define/public (get-scroll-range which) - (if (is-auto-scroll?) + (if (or (is-disabled-scroll-dir? which) (is-auto-scroll?)) 0 (->long (dispatch which (lambda (adj) (- (gtk_adjustment_get_upper adj) (gtk_adjustment_get_page_size adj))) 0)))) (define/public (get-scroll-pos which) - (if (is-auto-scroll?) + (if (or (is-disabled-scroll-dir? which) (is-auto-scroll?)) 0 (->long (dispatch which gtk_adjustment_get_value 0)))) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index c2759457..8f965dc5 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -70,7 +70,7 @@ SIF_PAGE SIF_TRACKPOS) 0 0 0 0 0)) -> (r : _BOOL) - -> (if r i (error 'GetScrollInfo "failed")))) + -> (if r i (failed 'GetScrollInfo)))) (define COMBO-WIDTH 18) @@ -87,7 +87,8 @@ get-client-size get-eventspace set-control-font - is-auto-scroll? get-virtual-width get-virtual-height + is-auto-scroll? is-disabled-scroll? + get-virtual-width get-virtual-height reset-auto-scroll refresh-for-autoscroll) @@ -416,12 +417,18 @@ (define/override (get-virtual-v-pos) (GetScrollPos canvas-hwnd SB_VERT)) + (define/private (is-disabled-scroll-dir? which) + (or (if (eq? which 'vertical) + (not vscroll?) + (not hscroll?)) + (is-disabled-scroll?))) + (define/public (get-scroll-pos which) - (if (is-auto-scroll?) + (if (or (is-disabled-scroll-dir? which) (is-auto-scroll?)) 0 (GetScrollPos canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ)))) (define/public (get-scroll-range which) - (if (is-auto-scroll?) + (if (or (is-disabled-scroll-dir? which) (is-auto-scroll?)) 0 (get-real-scroll-range which))) (define/public (get-real-scroll-range which) @@ -430,7 +437,7 @@ (SCROLLINFO-nPage i)) 1))) (define/public (get-scroll-page which) - (if (is-auto-scroll?) + (if (or (is-disabled-scroll-dir? which) (is-auto-scroll?)) 0 (let ([i (GetScrollInfo canvas-hwnd (if (eq? which 'vertical) SB_VERT SB_HORZ))]) (SCROLLINFO-nPage i)))) diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index d1d74354..3452d43b 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -909,8 +909,21 @@ (send parent delete-child t) (loop (cdr styles))))) - (let ([c (make-object canvas% parent '(hscroll vscroll))]) + (define (check-canvas-no-scroll c) + (st 0 c get-scroll-range 'vertical) + (st 0 c get-scroll-range 'horizontal) + (st 0 c get-scroll-page 'vertical) + (st 0 c get-scroll-page 'horizontal) + (st 0 c get-scroll-pos 'vertical) + (st 0 c get-scroll-pos 'horizontal)) + (let ([c (make-object canvas% parent '())]) + (check-canvas-no-scroll c) + (stv c init-manual-scrollbars 5 6 2 3 4 5) + (check-canvas-no-scroll c)) + + (let ([c (make-object canvas% parent '(hscroll vscroll))]) + (printf "Tab Focus\n") (st #f c accept-tab-focus) (stv c accept-tab-focus #t) @@ -918,6 +931,8 @@ (stv c accept-tab-focus #f) (st #f c accept-tab-focus) + (check-canvas-no-scroll c) + (stv c init-auto-scrollbars 500 606 .02 .033) ; (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t) (let-values ([(w h) (send c get-virtual-size)]