suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/gui: fix access of scrollbar values for canvas without a scrollbar

Browse Source 
original commit: 1800680c6ba0dec0f8b2f7d0495c615906b27b47
This commit is contained in:
Matthew Flatt 2012-08-12 19:08:17 -06:00
parent 7dde3f4f90
commit 0e2b88e51a
5 changed files with 58 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -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?

3
collects/mred/private/wx/common/canvas-mixin.rkt
View File

@ -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)

15
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -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))))

17
collects/mred/private/wx/win32/canvas.rkt
View File

@ -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))))

17
collects/tests/gracket/windowing.rktl
View File

@ -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)]