unify cocoa & gtk canvas-painting implementation
This commit is contained in:
Matthew Flatt
parent
73d28a3fff
commit
f40e7edae8
File diff suppressed because it is too large
Load Diff
|
|
@ -35,8 +35,9 @@
|
|||
|
||||
(define/override (release-bitmap-storage)
|
||||
(atomically
|
||||
(cairo_surface_destroy s)
|
||||
(set! s #f)))))
|
||||
(when s
|
||||
(cairo_surface_destroy s)
|
||||
(set! s #f))))))
|
||||
|
||||
(define dc%
|
||||
(class backing-dc%
|
||||
|
|
|
|||
|
|
@ -475,8 +475,10 @@
|
|||
(and on? #t))
|
||||
(tellv cocoa zoom: cocoa)))
|
||||
|
||||
(def/public-unimplemented iconized?)
|
||||
(def/public-unimplemented iconize)
|
||||
(define/public (iconized?)
|
||||
(tell #:type _BOOL cocoa isMiniaturized))
|
||||
(define/public (iconize on?)
|
||||
(tellv cocoa miniaturize: cocoa))
|
||||
|
||||
(define/public (set-title s)
|
||||
(tellv cocoa setTitle: #:type _NSString s))))
|
||||
|
|
|
|||
|
|
@ -663,7 +663,8 @@
|
|||
(do-request-flush-delay
|
||||
cocoa-win
|
||||
(lambda (cocoa-win)
|
||||
(tellv cocoa-win disableFlushWindow))
|
||||
(tellv cocoa-win disableFlushWindow)
|
||||
#t)
|
||||
(lambda (cocoa-win)
|
||||
(tellv cocoa-win enableFlushWindow))))
|
||||
|
||||
|
|
|
|||
58
collects/mred/private/wx/common/canvas-mixin.rkt
Normal file
58
collects/mred/private/wx/common/canvas-mixin.rkt
Normal file
|
|
@ -0,0 +1,58 @@
|
|||
#lang racket/base
|
||||
(require racket/class
|
||||
"backing-dc.rkt")
|
||||
|
||||
(provide canvas-mixin)
|
||||
|
||||
(define (canvas-mixin %)
|
||||
(class %
|
||||
(super-new)
|
||||
(inherit request-canvas-flush-delay
|
||||
cancel-canvas-flush-delay
|
||||
queue-canvas-refresh-event
|
||||
is-shown-to-root?
|
||||
on-paint
|
||||
queue-backing-flush
|
||||
get-dc
|
||||
get-canvas-background)
|
||||
|
||||
;; Avoid multiple queued paints, and also allow cancel
|
||||
;; of queued paint:
|
||||
(define paint-queued #f) ; #f or (box #t)
|
||||
|
||||
(define/override (queue-paint)
|
||||
;; can be called from any thread, including the event-pump thread
|
||||
(unless paint-queued
|
||||
(let ([b (box #t)])
|
||||
(set! paint-queued b)
|
||||
(let ([req (request-canvas-flush-delay)])
|
||||
(queue-canvas-refresh-event
|
||||
(lambda () (do-on-paint req b)))))))
|
||||
|
||||
(define/private (do-on-paint req b)
|
||||
;; only called in the handler thread
|
||||
(when (or (not b) (unbox b))
|
||||
(let ([pq paint-queued])
|
||||
(when pq (set-box! pq #f)))
|
||||
(set! paint-queued #f)
|
||||
(when (or (not b) (is-shown-to-root?))
|
||||
(let ([dc (get-dc)])
|
||||
(send dc suspend-flush)
|
||||
(send dc ensure-ready)
|
||||
(send dc erase) ; start with a clean slate
|
||||
(let ([bg (get-canvas-background)])
|
||||
(when bg
|
||||
(let ([old-bg (send dc get-background)])
|
||||
(send dc set-background bg)
|
||||
(send dc clear)
|
||||
(send dc set-background old-bg))))
|
||||
(on-paint)
|
||||
(send dc resume-flush)
|
||||
(queue-backing-flush))))
|
||||
(when req
|
||||
(cancel-canvas-flush-delay req)))
|
||||
|
||||
(define/override (paint-children)
|
||||
(when (or paint-queued
|
||||
(not (send (get-dc) can-backing-flush?)))
|
||||
(do-on-paint #f #f)))))
|
||||
|
|
@ -8,15 +8,17 @@
|
|||
(define (do-request-flush-delay win disable enable)
|
||||
(atomically
|
||||
(let ([req (box win)])
|
||||
(disable win)
|
||||
(add-event-boundary-sometimes-callback!
|
||||
req
|
||||
(lambda (v)
|
||||
;; in atomic mode
|
||||
(when (unbox req)
|
||||
(set-box! req #f)
|
||||
(enable win))))
|
||||
req)))
|
||||
(and
|
||||
(disable win)
|
||||
(begin
|
||||
(add-event-boundary-sometimes-callback!
|
||||
req
|
||||
(lambda (v)
|
||||
;; in atomic mode
|
||||
(when (unbox req)
|
||||
(set-box! req #f)
|
||||
(enable win))))
|
||||
req)))))
|
||||
|
||||
(define (do-cancel-flush-delay req enable)
|
||||
(atomically
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
racket/draw/color
|
||||
racket/draw/local
|
||||
"../common/backing-dc.rkt"
|
||||
"../common/canvas-mixin.rkt"
|
||||
"../../syntax.rkt"
|
||||
"../../lock.rkt"
|
||||
"../common/event.rkt"
|
||||
|
|
@ -176,461 +177,434 @@
|
|||
#t)
|
||||
|
||||
(define canvas%
|
||||
(class (client-size-mixin window%)
|
||||
(init parent
|
||||
x y w h
|
||||
style
|
||||
[ignored-name #f]
|
||||
[gl-config #f])
|
||||
(canvas-mixin
|
||||
(class (client-size-mixin window%)
|
||||
(init parent
|
||||
x y w h
|
||||
style
|
||||
[ignored-name #f]
|
||||
[gl-config #f])
|
||||
|
||||
(inherit get-gtk set-size get-size get-client-size
|
||||
on-size get-top-win
|
||||
set-auto-size
|
||||
adjust-client-delta infer-client-delta)
|
||||
(inherit get-gtk set-size get-size get-client-size
|
||||
on-size get-top-win
|
||||
set-auto-size
|
||||
adjust-client-delta infer-client-delta)
|
||||
|
||||
(define is-combo? (memq 'combo style))
|
||||
(define has-border? (or (memq 'border style)
|
||||
(memq 'control-border style)))
|
||||
(define is-combo? (memq 'combo style))
|
||||
(define has-border? (or (memq 'border style)
|
||||
(memq 'control-border style)))
|
||||
|
||||
(define margin (if has-border? 1 0))
|
||||
(define margin (if has-border? 1 0))
|
||||
|
||||
(define auto-scroll? #f)
|
||||
(define virtual-height #f)
|
||||
(define virtual-width #f)
|
||||
(define auto-scroll? #f)
|
||||
(define virtual-height #f)
|
||||
(define virtual-width #f)
|
||||
|
||||
(define-values (client-gtk gtk
|
||||
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
|
||||
combo-button-gtk
|
||||
scroll-width)
|
||||
(atomically ;; need to connect all children to gtk to avoid leaks
|
||||
(cond
|
||||
[(or (memq 'hscroll style)
|
||||
(memq 'vscroll style))
|
||||
(let* ([client-gtk (gtk_drawing_area_new)]
|
||||
[hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]
|
||||
[vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)])
|
||||
(let ([h (as-gtk-allocation (gtk_hbox_new #f 0))]
|
||||
[v (gtk_vbox_new #f 0)]
|
||||
[v2 (gtk_vbox_new #f 0)]
|
||||
[h2 (gtk_vbox_new #f 0)]
|
||||
[hscroll (gtk_hscrollbar_new hadj)]
|
||||
[vscroll (gtk_vscrollbar_new vadj)]
|
||||
[resize-box (gtk_drawing_area_new)])
|
||||
;; |------------------------------------|
|
||||
;; | h |-----------------| |-----------||
|
||||
;; | | v | | v2 ||
|
||||
;; | | | | [vscroll] ||
|
||||
;; | | [h2 [hscroll]] | | [resize] ||
|
||||
;; | |-----------------| |-----------||
|
||||
;; |------------------------------------|
|
||||
(when has-border?
|
||||
(gtk_container_set_border_width h margin))
|
||||
(gtk_box_pack_start h v #t #t 0)
|
||||
(gtk_box_pack_start v client-gtk #t #t 0)
|
||||
(gtk_box_pack_start h v2 #f #f 0)
|
||||
(gtk_box_pack_start v2 vscroll #t #t 0)
|
||||
(gtk_box_pack_start v h2 #f #f 0)
|
||||
(gtk_box_pack_start h2 hscroll #t #t 0)
|
||||
(gtk_box_pack_start v2 resize-box #f #f 0)
|
||||
(when (memq 'hscroll style)
|
||||
(gtk_widget_show hscroll))
|
||||
(gtk_widget_show vscroll)
|
||||
(gtk_widget_show h)
|
||||
(gtk_widget_show v)
|
||||
(when (memq 'vscroll style)
|
||||
(gtk_widget_show v2))
|
||||
(gtk_widget_show h2)
|
||||
(when (memq 'hscroll style)
|
||||
(gtk_widget_show resize-box))
|
||||
(gtk_widget_show client-gtk)
|
||||
(let ([req (make-GtkRequisition 0 0)])
|
||||
(gtk_widget_size_request vscroll req)
|
||||
(values client-gtk h hadj vadj
|
||||
(and (memq 'hscroll style) h2)
|
||||
(and (memq 'vscroll style) v2)
|
||||
(and (memq 'hscroll style) (memq 'vscroll style) resize-box)
|
||||
#f
|
||||
(GtkRequisition-width req)))))]
|
||||
[is-combo?
|
||||
(let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))]
|
||||
[orig-entry (gtk_bin_get_child gtk)])
|
||||
(values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))]
|
||||
[has-border?
|
||||
(let ([client-gtk (gtk_drawing_area_new)]
|
||||
[h (as-gtk-allocation (gtk_hbox_new #f 0))])
|
||||
(gtk_box_pack_start h client-gtk #t #t 0)
|
||||
(gtk_container_set_border_width h margin)
|
||||
(connect-expose-border h)
|
||||
(gtk_widget_show client-gtk)
|
||||
(values client-gtk h #f #f #f #f #f #f 0))]
|
||||
[else
|
||||
(let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
|
||||
(values client-gtk client-gtk #f #f #f #f #f #f 0))])))
|
||||
|
||||
(super-new [parent parent]
|
||||
[gtk gtk]
|
||||
[client-gtk client-gtk]
|
||||
[no-show? (memq 'deleted style)]
|
||||
[extra-gtks (if (eq? client-gtk gtk)
|
||||
null
|
||||
(if hscroll-adj
|
||||
(list client-gtk hscroll-adj vscroll-adj)
|
||||
(if combo-button-gtk
|
||||
(list client-gtk combo-button-gtk)
|
||||
(list client-gtk))))])
|
||||
|
||||
(set-size x y w h)
|
||||
|
||||
(define dc (new dc% [canvas this]))
|
||||
|
||||
(gtk_widget_realize gtk)
|
||||
(gtk_widget_realize client-gtk)
|
||||
|
||||
(when resize-box
|
||||
(let ([r (make-GtkRequisition 0 0)])
|
||||
(gtk_widget_size_request hscroll-gtk r)
|
||||
(gtk_widget_set_size_request resize-box
|
||||
(GtkRequisition-height r)
|
||||
(GtkRequisition-height r))))
|
||||
|
||||
(connect-expose client-gtk)
|
||||
#;(gtk_widget_set_double_buffered client-gtk #f)
|
||||
(connect-key-and-mouse client-gtk)
|
||||
(connect-focus client-gtk)
|
||||
(gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK
|
||||
GDK_KEY_RELEASE_MASK
|
||||
GDK_BUTTON_PRESS_MASK
|
||||
GDK_BUTTON_RELEASE_MASK
|
||||
GDK_POINTER_MOTION_MASK
|
||||
GDK_FOCUS_CHANGE_MASK
|
||||
GDK_ENTER_NOTIFY_MASK
|
||||
GDK_LEAVE_NOTIFY_MASK))
|
||||
(unless (memq 'no-focus style)
|
||||
(set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk)
|
||||
GTK_CAN_FOCUS)))
|
||||
(when combo-button-gtk
|
||||
(connect-combo-key-and-mouse combo-button-gtk))
|
||||
|
||||
(when hscroll-adj (connect-value-changed-h hscroll-adj))
|
||||
(when vscroll-adj (connect-value-changed-v vscroll-adj))
|
||||
|
||||
(set-auto-size)
|
||||
(adjust-client-delta (+ (* 2 margin)
|
||||
(if (memq 'vscroll style)
|
||||
scroll-width
|
||||
0))
|
||||
(+ (* 2 margin)
|
||||
(if (memq 'hscroll style)
|
||||
scroll-width
|
||||
0)))
|
||||
|
||||
(define/override (direct-update?) #f)
|
||||
|
||||
(define/public (get-dc) dc)
|
||||
|
||||
(define/public (make-compatible-bitmap w h)
|
||||
(send dc make-backing-bitmap w h))
|
||||
|
||||
(define/override (get-client-gtk) client-gtk)
|
||||
(define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
|
||||
|
||||
(define/override (get-client-delta)
|
||||
(values margin margin))
|
||||
|
||||
;; Avoid multiple queued paints:
|
||||
(define paint-queued? #f)
|
||||
;; To handle paint requests that happen while on-paint
|
||||
;; is being called already. kProbably doesn't happen,
|
||||
;; because expose callabcks should be in the right
|
||||
;; eventspace.
|
||||
(define now-drawing? #f)
|
||||
(define refresh-after-drawing? #f)
|
||||
|
||||
(define/public (queue-paint)
|
||||
;; can be called from any thread, including the event-pump thread
|
||||
(unless paint-queued?
|
||||
(set! paint-queued? #t)
|
||||
(queue-window-refresh-event
|
||||
this
|
||||
(lambda ()
|
||||
(set! paint-queued? #f)
|
||||
(set! now-drawing? #t)
|
||||
(send dc suspend-flush)
|
||||
(send dc ensure-ready)
|
||||
(send dc erase) ; clean slate
|
||||
(let ([bg (get-canvas-background)])
|
||||
(when bg
|
||||
(let ([old-bg (send dc get-background)])
|
||||
(send dc set-background bg)
|
||||
(send dc clear)
|
||||
(send dc set-background old-bg))))
|
||||
(on-paint)
|
||||
(send dc resume-flush)
|
||||
(set! now-drawing? #f)
|
||||
(when refresh-after-drawing?
|
||||
(set! refresh-after-drawing? #f)
|
||||
(refresh))))))
|
||||
|
||||
(define/public (paint-or-queue-paint)
|
||||
(or (do-backing-flush this dc (if is-combo?
|
||||
(get-subwindow client-gtk)
|
||||
(widget-window client-gtk)))
|
||||
(begin
|
||||
(queue-paint)
|
||||
#f)))
|
||||
|
||||
(define/public (on-paint) (void))
|
||||
|
||||
(define/public (get-flush-window) client-gtk)
|
||||
|
||||
(define/public (begin-refresh-sequence)
|
||||
(send dc suspend-flush))
|
||||
(define/public (end-refresh-sequence)
|
||||
(send dc resume-flush))
|
||||
|
||||
(define/override (refresh)
|
||||
(queue-paint))
|
||||
|
||||
(define/public (queue-backing-flush)
|
||||
;; called atomically (not expecting exceptions)
|
||||
(gtk_widget_queue_draw client-gtk))
|
||||
|
||||
(define/override (reset-child-dcs)
|
||||
(when (dc . is-a? . dc%)
|
||||
(reset-dc)))
|
||||
|
||||
(send dc start-backing-retained)
|
||||
|
||||
(define/private (reset-dc)
|
||||
(send dc reset-backing-retained)
|
||||
(refresh)
|
||||
(send dc set-auto-scroll
|
||||
(if virtual-width
|
||||
(gtk_adjustment_get_value hscroll-adj)
|
||||
0)
|
||||
(if virtual-height
|
||||
(gtk_adjustment_get_value vscroll-adj)
|
||||
0)))
|
||||
|
||||
(define/override (internal-on-client-size w h)
|
||||
(reset-dc))
|
||||
(define/override (on-client-size w h)
|
||||
(let ([xb (box 0)]
|
||||
[yb (box 0)])
|
||||
(get-size xb yb)
|
||||
(on-size (unbox xb) (unbox yb))))
|
||||
|
||||
(define/public (show-scrollbars h? v?)
|
||||
(when hscroll-gtk
|
||||
(if h?
|
||||
(gtk_widget_show hscroll-gtk)
|
||||
(gtk_widget_hide hscroll-gtk)))
|
||||
(when vscroll-gtk
|
||||
(if v?
|
||||
(gtk_widget_show vscroll-gtk)
|
||||
(gtk_widget_hide vscroll-gtk)))
|
||||
(when (and hscroll-gtk vscroll-gtk)
|
||||
(define-values (client-gtk gtk
|
||||
hscroll-adj vscroll-adj hscroll-gtk vscroll-gtk resize-box
|
||||
combo-button-gtk
|
||||
scroll-width)
|
||||
(atomically ;; need to connect all children to gtk to avoid leaks
|
||||
(cond
|
||||
[(and v? h?)
|
||||
(gtk_widget_show resize-box)]
|
||||
[(and v? (not h?))
|
||||
;; remove corner
|
||||
(gtk_widget_hide resize-box)]))
|
||||
(adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0))
|
||||
(+ (* 2 margin) (if h? scroll-width 0))))
|
||||
|
||||
(define/private (configure-adj adj scroll-gtk len page pos)
|
||||
(when (and scroll-gtk adj)
|
||||
(if (zero? len)
|
||||
(gtk_adjustment_configure adj 0 0 1 1 1 1)
|
||||
(gtk_adjustment_configure adj pos 0 (+ len page) 1 page page))))
|
||||
|
||||
(define/public (set-scrollbars h-step v-step
|
||||
h-len v-len
|
||||
h-page v-page
|
||||
h-pos v-pos
|
||||
auto?)
|
||||
(let ([h-page (if (zero? h-len) 0 h-page)]
|
||||
[v-page (if (zero? v-len) 0 v-page)])
|
||||
(cond
|
||||
[auto?
|
||||
(set! auto-scroll? #t)
|
||||
(set! virtual-width (and (positive? h-len) hscroll-gtk h-len))
|
||||
(set! virtual-height (and (positive? v-len) vscroll-gtk v-len))
|
||||
(reset-auto-scroll h-pos v-pos)
|
||||
(refresh-for-autoscroll)]
|
||||
[(or (memq 'hscroll style)
|
||||
(memq 'vscroll style))
|
||||
(let* ([client-gtk (gtk_drawing_area_new)]
|
||||
[hadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)]
|
||||
[vadj (gtk_adjustment_new 0.0 0.0 1.0 1.0 1.0 1.0)])
|
||||
(let ([h (as-gtk-allocation (gtk_hbox_new #f 0))]
|
||||
[v (gtk_vbox_new #f 0)]
|
||||
[v2 (gtk_vbox_new #f 0)]
|
||||
[h2 (gtk_vbox_new #f 0)]
|
||||
[hscroll (gtk_hscrollbar_new hadj)]
|
||||
[vscroll (gtk_vscrollbar_new vadj)]
|
||||
[resize-box (gtk_drawing_area_new)])
|
||||
;; |------------------------------------|
|
||||
;; | h |-----------------| |-----------||
|
||||
;; | | v | | v2 ||
|
||||
;; | | | | [vscroll] ||
|
||||
;; | | [h2 [hscroll]] | | [resize] ||
|
||||
;; | |-----------------| |-----------||
|
||||
;; |------------------------------------|
|
||||
(when has-border?
|
||||
(gtk_container_set_border_width h margin))
|
||||
(gtk_box_pack_start h v #t #t 0)
|
||||
(gtk_box_pack_start v client-gtk #t #t 0)
|
||||
(gtk_box_pack_start h v2 #f #f 0)
|
||||
(gtk_box_pack_start v2 vscroll #t #t 0)
|
||||
(gtk_box_pack_start v h2 #f #f 0)
|
||||
(gtk_box_pack_start h2 hscroll #t #t 0)
|
||||
(gtk_box_pack_start v2 resize-box #f #f 0)
|
||||
(when (memq 'hscroll style)
|
||||
(gtk_widget_show hscroll))
|
||||
(gtk_widget_show vscroll)
|
||||
(gtk_widget_show h)
|
||||
(gtk_widget_show v)
|
||||
(when (memq 'vscroll style)
|
||||
(gtk_widget_show v2))
|
||||
(gtk_widget_show h2)
|
||||
(when (memq 'hscroll style)
|
||||
(gtk_widget_show resize-box))
|
||||
(gtk_widget_show client-gtk)
|
||||
(let ([req (make-GtkRequisition 0 0)])
|
||||
(gtk_widget_size_request vscroll req)
|
||||
(values client-gtk h hadj vadj
|
||||
(and (memq 'hscroll style) h2)
|
||||
(and (memq 'vscroll style) v2)
|
||||
(and (memq 'hscroll style) (memq 'vscroll style) resize-box)
|
||||
#f
|
||||
(GtkRequisition-width req)))))]
|
||||
[is-combo?
|
||||
(let* ([gtk (as-gtk-allocation (gtk_combo_box_entry_new_text))]
|
||||
[orig-entry (gtk_bin_get_child gtk)])
|
||||
(values orig-entry gtk #f #f #f #f #f (extract-combo-button gtk) 0))]
|
||||
[has-border?
|
||||
(let ([client-gtk (gtk_drawing_area_new)]
|
||||
[h (as-gtk-allocation (gtk_hbox_new #f 0))])
|
||||
(gtk_box_pack_start h client-gtk #t #t 0)
|
||||
(gtk_container_set_border_width h margin)
|
||||
(connect-expose-border h)
|
||||
(gtk_widget_show client-gtk)
|
||||
(values client-gtk h #f #f #f #f #f #f 0))]
|
||||
[else
|
||||
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
|
||||
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)])))
|
||||
(let ([client-gtk (as-gtk-allocation (gtk_drawing_area_new))])
|
||||
(values client-gtk client-gtk #f #f #f #f #f #f 0))])))
|
||||
|
||||
(define/private (reset-auto-scroll h-pos v-pos)
|
||||
(let ([xb (box 0)]
|
||||
[yb (box 0)])
|
||||
(get-client-size xb yb)
|
||||
(let ([cw (unbox xb)]
|
||||
[ch (unbox yb)])
|
||||
(let ([h-len (if virtual-width
|
||||
(max 0 (- virtual-width cw))
|
||||
0)]
|
||||
[v-len (if virtual-height
|
||||
(max 0 (- virtual-height ch))
|
||||
0)]
|
||||
[h-page (if virtual-width
|
||||
cw
|
||||
(super-new [parent parent]
|
||||
[gtk gtk]
|
||||
[client-gtk client-gtk]
|
||||
[no-show? (memq 'deleted style)]
|
||||
[extra-gtks (if (eq? client-gtk gtk)
|
||||
null
|
||||
(if hscroll-adj
|
||||
(list client-gtk hscroll-adj vscroll-adj)
|
||||
(if combo-button-gtk
|
||||
(list client-gtk combo-button-gtk)
|
||||
(list client-gtk))))])
|
||||
|
||||
(set-size x y w h)
|
||||
|
||||
(define dc (new dc% [canvas this]))
|
||||
|
||||
(gtk_widget_realize gtk)
|
||||
(gtk_widget_realize client-gtk)
|
||||
|
||||
(when resize-box
|
||||
(let ([r (make-GtkRequisition 0 0)])
|
||||
(gtk_widget_size_request hscroll-gtk r)
|
||||
(gtk_widget_set_size_request resize-box
|
||||
(GtkRequisition-height r)
|
||||
(GtkRequisition-height r))))
|
||||
|
||||
(connect-expose client-gtk)
|
||||
#;(gtk_widget_set_double_buffered client-gtk #f)
|
||||
(connect-key-and-mouse client-gtk)
|
||||
(connect-focus client-gtk)
|
||||
(gtk_widget_add_events client-gtk (bitwise-ior GDK_KEY_PRESS_MASK
|
||||
GDK_KEY_RELEASE_MASK
|
||||
GDK_BUTTON_PRESS_MASK
|
||||
GDK_BUTTON_RELEASE_MASK
|
||||
GDK_POINTER_MOTION_MASK
|
||||
GDK_FOCUS_CHANGE_MASK
|
||||
GDK_ENTER_NOTIFY_MASK
|
||||
GDK_LEAVE_NOTIFY_MASK))
|
||||
(unless (memq 'no-focus style)
|
||||
(set-gtk-object-flags! client-gtk (bitwise-ior (get-gtk-object-flags client-gtk)
|
||||
GTK_CAN_FOCUS)))
|
||||
(when combo-button-gtk
|
||||
(connect-combo-key-and-mouse combo-button-gtk))
|
||||
|
||||
(when hscroll-adj (connect-value-changed-h hscroll-adj))
|
||||
(when vscroll-adj (connect-value-changed-v vscroll-adj))
|
||||
|
||||
(set-auto-size)
|
||||
(adjust-client-delta (+ (* 2 margin)
|
||||
(if (memq 'vscroll style)
|
||||
scroll-width
|
||||
0))
|
||||
(+ (* 2 margin)
|
||||
(if (memq 'hscroll style)
|
||||
scroll-width
|
||||
0)))
|
||||
|
||||
(define/override (direct-update?) #f)
|
||||
|
||||
(define/public (get-dc) dc)
|
||||
|
||||
(define/public (make-compatible-bitmap w h)
|
||||
(send dc make-backing-bitmap w h))
|
||||
|
||||
(define/override (get-client-gtk) client-gtk)
|
||||
(define/override (handles-events? gtk) (not (ptr-equal? gtk combo-button-gtk)))
|
||||
|
||||
(define/override (get-client-delta)
|
||||
(values margin margin))
|
||||
|
||||
;; The `queue-paint' and `paint-children' methods
|
||||
;; are defined by `canvas-mixin' from ../common/canvas-mixin
|
||||
(define/public (queue-paint) (void))
|
||||
(define/public (request-canvas-flush-delay)
|
||||
(request-flush-delay client-gtk))
|
||||
(define/public (cancel-canvas-flush-delay req)
|
||||
(cancel-flush-delay req))
|
||||
(define/public (queue-canvas-refresh-event thunk)
|
||||
(queue-window-refresh-event this thunk))
|
||||
|
||||
(define/public (paint-or-queue-paint)
|
||||
(or (do-backing-flush this dc (if is-combo?
|
||||
(get-subwindow client-gtk)
|
||||
(widget-window client-gtk)))
|
||||
(begin
|
||||
(queue-paint)
|
||||
#f)))
|
||||
|
||||
(define/public (on-paint) (void))
|
||||
|
||||
(define/public (get-flush-window) client-gtk)
|
||||
|
||||
(define/public (begin-refresh-sequence)
|
||||
(send dc suspend-flush))
|
||||
(define/public (end-refresh-sequence)
|
||||
(send dc resume-flush))
|
||||
|
||||
(define/override (refresh)
|
||||
(queue-paint))
|
||||
|
||||
(define/public (queue-backing-flush)
|
||||
;; called atomically (not expecting exceptions)
|
||||
(gtk_widget_queue_draw client-gtk))
|
||||
|
||||
(define/override (reset-child-dcs)
|
||||
(when (dc . is-a? . dc%)
|
||||
(reset-dc)))
|
||||
|
||||
(send dc start-backing-retained)
|
||||
|
||||
(define/private (reset-dc)
|
||||
(send dc reset-backing-retained)
|
||||
(refresh)
|
||||
(send dc set-auto-scroll
|
||||
(if virtual-width
|
||||
(gtk_adjustment_get_value hscroll-adj)
|
||||
0)
|
||||
(if virtual-height
|
||||
(gtk_adjustment_get_value vscroll-adj)
|
||||
0)))
|
||||
|
||||
(define/override (internal-on-client-size w h)
|
||||
(reset-dc))
|
||||
(define/override (on-client-size w h)
|
||||
(let ([xb (box 0)]
|
||||
[yb (box 0)])
|
||||
(get-size xb yb)
|
||||
(on-size (unbox xb) (unbox yb))))
|
||||
|
||||
(define/public (show-scrollbars h? v?)
|
||||
(when hscroll-gtk
|
||||
(if h?
|
||||
(gtk_widget_show hscroll-gtk)
|
||||
(gtk_widget_hide hscroll-gtk)))
|
||||
(when vscroll-gtk
|
||||
(if v?
|
||||
(gtk_widget_show vscroll-gtk)
|
||||
(gtk_widget_hide vscroll-gtk)))
|
||||
(when (and hscroll-gtk vscroll-gtk)
|
||||
(cond
|
||||
[(and v? h?)
|
||||
(gtk_widget_show resize-box)]
|
||||
[(and v? (not h?))
|
||||
;; remove corner
|
||||
(gtk_widget_hide resize-box)]))
|
||||
(adjust-client-delta (+ (* 2 margin) (if v? scroll-width 0))
|
||||
(+ (* 2 margin) (if h? scroll-width 0))))
|
||||
|
||||
(define/private (configure-adj adj scroll-gtk len page pos)
|
||||
(when (and scroll-gtk adj)
|
||||
(if (zero? len)
|
||||
(gtk_adjustment_configure adj 0 0 1 1 1 1)
|
||||
(gtk_adjustment_configure adj pos 0 (+ len page) 1 page page))))
|
||||
|
||||
(define/public (set-scrollbars h-step v-step
|
||||
h-len v-len
|
||||
h-page v-page
|
||||
h-pos v-pos
|
||||
auto?)
|
||||
(let ([h-page (if (zero? h-len) 0 h-page)]
|
||||
[v-page (if (zero? v-len) 0 v-page)])
|
||||
(cond
|
||||
[auto?
|
||||
(set! auto-scroll? #t)
|
||||
(set! virtual-width (and (positive? h-len) hscroll-gtk h-len))
|
||||
(set! virtual-height (and (positive? v-len) vscroll-gtk v-len))
|
||||
(reset-auto-scroll h-pos v-pos)
|
||||
(refresh-for-autoscroll)]
|
||||
[else
|
||||
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
|
||||
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)])))
|
||||
|
||||
(define/private (reset-auto-scroll h-pos v-pos)
|
||||
(let ([xb (box 0)]
|
||||
[yb (box 0)])
|
||||
(get-client-size xb yb)
|
||||
(let ([cw (unbox xb)]
|
||||
[ch (unbox yb)])
|
||||
(let ([h-len (if virtual-width
|
||||
(max 0 (- virtual-width cw))
|
||||
0)]
|
||||
[v-page (if virtual-height
|
||||
ch
|
||||
0)])
|
||||
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
|
||||
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)))))
|
||||
[v-len (if virtual-height
|
||||
(max 0 (- virtual-height ch))
|
||||
0)]
|
||||
[h-page (if virtual-width
|
||||
cw
|
||||
0)]
|
||||
[v-page (if virtual-height
|
||||
ch
|
||||
0)])
|
||||
(configure-adj hscroll-adj hscroll-gtk h-len h-page h-pos)
|
||||
(configure-adj vscroll-adj vscroll-gtk v-len v-page v-pos)))))
|
||||
|
||||
(define/private (refresh-for-autoscroll)
|
||||
(reset-dc)
|
||||
(refresh))
|
||||
(define/private (refresh-for-autoscroll)
|
||||
(reset-dc)
|
||||
(refresh))
|
||||
|
||||
(define/private (dispatch which proc [default (void)])
|
||||
(if (eq? which 'vertical)
|
||||
(if vscroll-adj (proc vscroll-adj) default)
|
||||
(if hscroll-adj (proc hscroll-adj) default)))
|
||||
(define/private (dispatch which proc [default (void)])
|
||||
(if (eq? which 'vertical)
|
||||
(if vscroll-adj (proc vscroll-adj) default)
|
||||
(if hscroll-adj (proc hscroll-adj) default)))
|
||||
|
||||
(define/public (set-scroll-page which v)
|
||||
(dispatch which (lambda (adj)
|
||||
(let ([old (gtk_adjustment_get_page_size adj)])
|
||||
(unless (= old v)
|
||||
(gtk_adjustment_set_page_size adj v)
|
||||
(gtk_adjustment_set_page_increment adj v)
|
||||
(gtk_adjustment_set_upper adj (+ (- v old)
|
||||
(gtk_adjustment_get_upper adj))))))))
|
||||
(define/public (set-scroll-range which v)
|
||||
(dispatch which (lambda (adj)
|
||||
(gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj))))))
|
||||
(define/public (set-scroll-pos which v)
|
||||
(dispatch which (lambda (adj) (gtk_adjustment_set_value adj v))))
|
||||
(define/public (set-scroll-page which v)
|
||||
(dispatch which (lambda (adj)
|
||||
(let ([old (gtk_adjustment_get_page_size adj)])
|
||||
(unless (= old v)
|
||||
(gtk_adjustment_set_page_size adj v)
|
||||
(gtk_adjustment_set_page_increment adj v)
|
||||
(gtk_adjustment_set_upper adj (+ (- v old)
|
||||
(gtk_adjustment_get_upper adj))))))))
|
||||
(define/public (set-scroll-range which v)
|
||||
(dispatch which (lambda (adj)
|
||||
(gtk_adjustment_set_upper adj (+ v (gtk_adjustment_get_page_size adj))))))
|
||||
(define/public (set-scroll-pos which v)
|
||||
(dispatch which (lambda (adj) (gtk_adjustment_set_value adj v))))
|
||||
|
||||
(define/public (get-scroll-page which)
|
||||
(->long (dispatch which gtk_adjustment_get_page_size 0)))
|
||||
(define/public (get-scroll-range which)
|
||||
(->long (dispatch which (lambda (adj)
|
||||
(- (gtk_adjustment_get_upper adj)
|
||||
(gtk_adjustment_get_page_size adj)))
|
||||
0)))
|
||||
(define/public (get-scroll-pos which)
|
||||
(->long (dispatch which gtk_adjustment_get_value 0)))
|
||||
|
||||
(define clear-bg?
|
||||
(and (not (memq 'transparent style))
|
||||
(not (memq 'no-autoclear style))))
|
||||
(define transparent?
|
||||
(memq 'transparent style))
|
||||
(define gc #f)
|
||||
(define bg-col (make-object color% "white"))
|
||||
(define/public (get-canvas-background) (if transparent?
|
||||
#f
|
||||
bg-col))
|
||||
(define/public (set-canvas-background col) (set! bg-col col))
|
||||
(define/public (get-canvas-background-for-clearing)
|
||||
;; called in event-dispatch mode
|
||||
(if now-drawing?
|
||||
(begin
|
||||
(set! refresh-after-drawing? #t)
|
||||
#f)
|
||||
(if clear-bg?
|
||||
(let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]
|
||||
[w (widget-window gtk)]
|
||||
[gc (gdk_gc_new w)])
|
||||
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0
|
||||
(conv (color-red bg-col))
|
||||
(conv (color-green bg-col))
|
||||
(conv (color-blue bg-col))))
|
||||
gc)
|
||||
#f)))
|
||||
(define/public (get-scroll-page which)
|
||||
(->long (dispatch which gtk_adjustment_get_page_size 0)))
|
||||
(define/public (get-scroll-range which)
|
||||
(->long (dispatch which (lambda (adj)
|
||||
(- (gtk_adjustment_get_upper adj)
|
||||
(gtk_adjustment_get_page_size adj)))
|
||||
0)))
|
||||
(define/public (get-scroll-pos which)
|
||||
(->long (dispatch which gtk_adjustment_get_value 0)))
|
||||
|
||||
(define clear-bg?
|
||||
(and (not (memq 'transparent style))
|
||||
(not (memq 'no-autoclear style))))
|
||||
(define transparent?
|
||||
(memq 'transparent style))
|
||||
(define gc #f)
|
||||
(define bg-col (make-object color% "white"))
|
||||
(define/public (get-canvas-background) (if transparent?
|
||||
#f
|
||||
bg-col))
|
||||
(define/public (set-canvas-background col) (set! bg-col col))
|
||||
(define/public (get-canvas-background-for-clearing)
|
||||
;; called in event-dispatch mode
|
||||
(if clear-bg?
|
||||
(let* ([conv (lambda (x) (bitwise-ior x (arithmetic-shift x 8)))]
|
||||
[w (widget-window gtk)]
|
||||
[gc (gdk_gc_new w)])
|
||||
(gdk_gc_set_rgb_fg_color gc (make-GdkColor 0
|
||||
(conv (color-red bg-col))
|
||||
(conv (color-green bg-col))
|
||||
(conv (color-blue bg-col))))
|
||||
gc)
|
||||
#f))
|
||||
|
||||
(when is-combo?
|
||||
(connect-changed client-gtk))
|
||||
(when is-combo?
|
||||
(connect-changed client-gtk))
|
||||
|
||||
(define/public (append-combo-item str)
|
||||
(gtk_combo_box_append_text gtk str))
|
||||
(define/public (append-combo-item str)
|
||||
(gtk_combo_box_append_text gtk str))
|
||||
|
||||
(define/public (combo-maybe-clicked)
|
||||
(let ([i (gtk_combo_box_get_active gtk)])
|
||||
(when (i . > . -1)
|
||||
(gtk_combo_box_set_active gtk -1)
|
||||
(queue-window-event this (lambda () (on-combo-select i))))))
|
||||
(define/public (on-combo-select i) (void))
|
||||
(define/public (combo-maybe-clicked)
|
||||
(let ([i (gtk_combo_box_get_active gtk)])
|
||||
(when (i . > . -1)
|
||||
(gtk_combo_box_set_active gtk -1)
|
||||
(queue-window-event this (lambda () (on-combo-select i))))))
|
||||
(define/public (on-combo-select i) (void))
|
||||
|
||||
(define/public (set-combo-text t) (void))
|
||||
(define/public (set-combo-text t) (void))
|
||||
|
||||
(def/public-unimplemented set-background-to-gray)
|
||||
(def/public-unimplemented set-background-to-gray)
|
||||
|
||||
(define/public (do-scroll direction)
|
||||
(if auto-scroll?
|
||||
(refresh-for-autoscroll)
|
||||
(on-scroll (new scroll-event%
|
||||
[event-type 'thumb]
|
||||
[direction direction]
|
||||
[position (get-scroll-pos direction)]))))
|
||||
(define/public (on-scroll e) (void))
|
||||
(define/public (do-scroll direction)
|
||||
(if auto-scroll?
|
||||
(refresh-for-autoscroll)
|
||||
(on-scroll (new scroll-event%
|
||||
[event-type 'thumb]
|
||||
[direction direction]
|
||||
[position (get-scroll-pos direction)]))))
|
||||
(define/public (on-scroll e) (void))
|
||||
|
||||
(define/public (scroll x y)
|
||||
(when hscroll-adj (gtk_adjustment_set_value hscroll-adj x))
|
||||
(when vscroll-adj (gtk_adjustment_set_value vscroll-adj y))
|
||||
(when auto-scroll? (refresh-for-autoscroll)))
|
||||
(define/public (scroll x y)
|
||||
(when hscroll-adj (gtk_adjustment_set_value hscroll-adj x))
|
||||
(when vscroll-adj (gtk_adjustment_set_value vscroll-adj y))
|
||||
(when auto-scroll? (refresh-for-autoscroll)))
|
||||
|
||||
(def/public-unimplemented warp-pointer)
|
||||
(def/public-unimplemented warp-pointer)
|
||||
|
||||
(define/public (view-start xb yb)
|
||||
(if auto-scroll?
|
||||
(begin
|
||||
(set-box! xb (if virtual-width
|
||||
(gtk_adjustment_get_value hscroll-adj)
|
||||
0))
|
||||
(set-box! yb (if virtual-height
|
||||
(gtk_adjustment_get_value vscroll-adj)
|
||||
0)))
|
||||
(begin
|
||||
(set-box! xb 0)
|
||||
(set-box! yb 0))))
|
||||
(define/public (view-start xb yb)
|
||||
(if auto-scroll?
|
||||
(begin
|
||||
(set-box! xb (if virtual-width
|
||||
(gtk_adjustment_get_value hscroll-adj)
|
||||
0))
|
||||
(set-box! yb (if virtual-height
|
||||
(gtk_adjustment_get_value vscroll-adj)
|
||||
0)))
|
||||
(begin
|
||||
(set-box! xb 0)
|
||||
(set-box! yb 0))))
|
||||
|
||||
(define/public (set-resize-corner on?) (void))
|
||||
|
||||
(define/public (get-virtual-size xb yb)
|
||||
(get-client-size xb yb)
|
||||
(when virtual-width (set-box! xb virtual-width))
|
||||
(when virtual-height (set-box! yb virtual-height)))
|
||||
(define/public (set-resize-corner on?) (void))
|
||||
|
||||
(define/public (get-virtual-size xb yb)
|
||||
(get-client-size xb yb)
|
||||
(when virtual-width (set-box! xb virtual-width))
|
||||
(when virtual-height (set-box! yb virtual-height)))
|
||||
|
||||
(define reg-blits null)
|
||||
|
||||
(define/private (register-one-blit x y w h on-pixbuf off-pixbuf)
|
||||
(let* ([cwin (widget-window client-gtk)])
|
||||
(atomically
|
||||
(let ([win (create-gc-window cwin x y w h)])
|
||||
(let ([r (scheme_add_gc_callback
|
||||
(make-gc-show-desc win on-pixbuf w h)
|
||||
(make-gc-hide-desc win off-pixbuf w h))])
|
||||
(cons win r))))))
|
||||
|
||||
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
|
||||
(let ([fix-size (lambda (on on-x on-y)
|
||||
(if (and (zero? on-x)
|
||||
(zero? on-y)
|
||||
(= (send on get-width) w)
|
||||
(= (send on get-height) h))
|
||||
on
|
||||
(let ([bm (make-object bitmap% w h)])
|
||||
(let ([dc (make-object bitmap-dc% on)])
|
||||
(send dc draw-bitmap-section on 0 0 on-x on-y w h)
|
||||
(send dc set-bitmap #f)
|
||||
bm))))])
|
||||
(let ([on (fix-size on on-x on-y)]
|
||||
[off (fix-size off off-x off-y)])
|
||||
(let ([on-pixbuf (bitmap->pixbuf on)]
|
||||
[off-pixbuf (bitmap->pixbuf off)])
|
||||
(atomically
|
||||
(set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits)))))))
|
||||
|
||||
(define/public (unregister-collecting-blits)
|
||||
(atomically
|
||||
(for ([r (in-list reg-blits)])
|
||||
(g_object_unref (car r))
|
||||
(scheme_remove_gc_callback (cdr r)))
|
||||
(set! reg-blits null)))))
|
||||
(define reg-blits null)
|
||||
|
||||
(define/private (register-one-blit x y w h on-pixbuf off-pixbuf)
|
||||
(let* ([cwin (widget-window client-gtk)])
|
||||
(atomically
|
||||
(let ([win (create-gc-window cwin x y w h)])
|
||||
(let ([r (scheme_add_gc_callback
|
||||
(make-gc-show-desc win on-pixbuf w h)
|
||||
(make-gc-hide-desc win off-pixbuf w h))])
|
||||
(cons win r))))))
|
||||
|
||||
(define/public (register-collecting-blit x y w h on off on-x on-y off-x off-y)
|
||||
(let ([fix-size (lambda (on on-x on-y)
|
||||
(if (and (zero? on-x)
|
||||
(zero? on-y)
|
||||
(= (send on get-width) w)
|
||||
(= (send on get-height) h))
|
||||
on
|
||||
(let ([bm (make-object bitmap% w h)])
|
||||
(let ([dc (make-object bitmap-dc% on)])
|
||||
(send dc draw-bitmap-section on 0 0 on-x on-y w h)
|
||||
(send dc set-bitmap #f)
|
||||
bm))))])
|
||||
(let ([on (fix-size on on-x on-y)]
|
||||
[off (fix-size off off-x off-y)])
|
||||
(let ([on-pixbuf (bitmap->pixbuf on)]
|
||||
[off-pixbuf (bitmap->pixbuf off)])
|
||||
(atomically
|
||||
(set! reg-blits (cons (register-one-blit x y w h on-pixbuf off-pixbuf) reg-blits)))))))
|
||||
|
||||
(define/public (unregister-collecting-blits)
|
||||
(atomically
|
||||
(for ([r (in-list reg-blits)])
|
||||
(g_object_unref (car r))
|
||||
(scheme_remove_gc_callback (cdr r)))
|
||||
(set! reg-blits null))))))
|
||||
|
|
|
|||
|
|
@ -237,14 +237,24 @@
|
|||
(gtk_window_resize gtk (max 1 w) (max 1 h)))
|
||||
|
||||
(define/override (show on?)
|
||||
(when (and on?
|
||||
(eventspace-shutdown? (get-eventspace)))
|
||||
(error (string->symbol
|
||||
(format "show method in ~a"
|
||||
(if (frame-relative-dialog-status this)
|
||||
'dialog%
|
||||
'frame%)))
|
||||
"eventspace has been shutdown"))
|
||||
(let ([es (get-eventspace)])
|
||||
(when (and on?
|
||||
(eventspace-shutdown? es))
|
||||
(error (string->symbol
|
||||
(format "show method in ~a"
|
||||
(if (frame-relative-dialog-status this)
|
||||
'dialog%
|
||||
'frame%)))
|
||||
"eventspace has been shutdown")
|
||||
(when saved-child
|
||||
(if (eq? (current-thread) (eventspace-handler-thread es))
|
||||
(send saved-child paint-children)
|
||||
(let ([s (make-semaphore)])
|
||||
(queue-callback (lambda ()
|
||||
(when saved-child
|
||||
(send saved-child paint-children))
|
||||
(semaphore-post s)))
|
||||
(sync/timeout 1 s))))))
|
||||
(super show on?))
|
||||
|
||||
(define saved-child #f)
|
||||
|
|
|
|||
|
|
@ -32,6 +32,11 @@
|
|||
(for ([child (in-list children)])
|
||||
(send child reset-child-dcs))))
|
||||
|
||||
(define/override (paint-children)
|
||||
(when (pair? children)
|
||||
(for ([child (in-list children)])
|
||||
(send child paint-children))))
|
||||
|
||||
(define/override (set-size x y w h)
|
||||
(super set-size x y w h)
|
||||
(reset-child-dcs))
|
||||
|
|
|
|||
|
|
@ -568,6 +568,9 @@
|
|||
(when parent
|
||||
(send parent register-child this on?)))
|
||||
|
||||
(define/public (paint-children)
|
||||
(void))
|
||||
|
||||
(def/public-unimplemented on-drop-file)
|
||||
(def/public-unimplemented get-handle)
|
||||
(def/public-unimplemented set-phantom-size)
|
||||
|
|
@ -625,12 +628,16 @@
|
|||
(do-request-flush-delay
|
||||
gtk
|
||||
(lambda (gtk)
|
||||
(gdk_window_freeze_updates (widget-window gtk)))
|
||||
(let ([win (widget-window gtk)])
|
||||
(and win
|
||||
(gdk_window_freeze_updates win)
|
||||
#t)))
|
||||
(lambda (gtk)
|
||||
(gdk_window_thaw_updates (widget-window gtk)))))
|
||||
|
||||
(define (cancel-flush-delay req)
|
||||
(do-cancel-flush-delay
|
||||
req
|
||||
(lambda (gtk)
|
||||
(gdk_window_thaw_updates (widget-window gtk)))))
|
||||
(when req
|
||||
(do-cancel-flush-delay
|
||||
req
|
||||
(lambda (gtk)
|
||||
(gdk_window_thaw_updates (widget-window gtk))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user