7789fcd827
In the "windowing.rktl" tests, for Gtk there are still race conditions between the program and the window manager. But for the first time ever, all platforms can pass the "windowing.rktl" test. original commit: 7da127227a3a493214b0878cd26bff6b51631115
486 lines
17 KiB
Racket
486 lines
17 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
racket/class
|
|
racket/promise
|
|
racket/runtime-path
|
|
racket/draw
|
|
(for-syntax (only-in racket/base quote))
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
"utils.rkt"
|
|
"const.rkt"
|
|
"types.rkt"
|
|
"window.rkt"
|
|
"client-window.rkt"
|
|
"widget.rkt"
|
|
"cursor.rkt"
|
|
"pixbuf.rkt"
|
|
"../common/queue.rkt")
|
|
|
|
(provide
|
|
(protect-out frame%
|
|
display-origin
|
|
display-size
|
|
location->window))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define GDK_GRAVITY_NORTH_WEST 1)
|
|
(define GDK_GRAVITY_STATIC 10)
|
|
|
|
(define _GList (_cpointer/null 'GList))
|
|
(define-glib g_list_insert (_fun _GList _pointer _int -> _GList))
|
|
(define-glib g_list_free (_fun _GList -> _void))
|
|
|
|
(define-gtk gtk_window_new (_fun _int -> _GtkWidget))
|
|
(define-gtk gtk_window_set_title (_fun _GtkWindow _string -> _void))
|
|
(define-gtk gtk_fixed_new (_fun -> _GtkWidget))
|
|
(define-gtk gtk_fixed_move (_fun _GtkWidget _GtkWidget _int _int -> _void))
|
|
(define-gtk gtk_window_get_size (_fun _GtkWidget (w : (_ptr o _int)) (h : (_ptr o _int))
|
|
-> _void
|
|
-> (values w h)))
|
|
(define-gtk gtk_window_set_decorated (_fun _GtkWidget _gboolean -> _void))
|
|
(define-gtk gtk_window_maximize (_fun _GtkWidget -> _void))
|
|
(define-gtk gtk_window_unmaximize (_fun _GtkWidget -> _void))
|
|
(define-gtk gtk_widget_set_uposition (_fun _GtkWidget _int _int -> _void))
|
|
(define-gtk gtk_window_get_position (_fun _GtkWidget (x : (_ptr o _int)) (y : (_ptr o _int))
|
|
-> _void
|
|
-> (values x y)))
|
|
(define-gtk gtk_window_set_gravity (_fun _GtkWindow _int -> _void))
|
|
(define-gtk gtk_window_set_icon_list (_fun _GtkWindow _GList -> _void))
|
|
(define-gtk gtk_window_fullscreen (_fun _GtkWindow -> _void))
|
|
|
|
(define-gtk gtk_window_resize (_fun _GtkWidget _int _int -> _void))
|
|
|
|
(define-gdk gdk_window_set_cursor (_fun _GdkWindow _pointer -> _void))
|
|
|
|
(define-gtk gtk_window_iconify (_fun _GtkWindow -> _void))
|
|
(define-gtk gtk_window_deiconify (_fun _GtkWindow -> _void))
|
|
|
|
(define-cstruct _GdkGeometry ([min_width _int]
|
|
[min_height _int]
|
|
[max_width _int]
|
|
[max_height _int]
|
|
[base_width _int]
|
|
[base_height _int]
|
|
[width_inc _int]
|
|
[height_inc _int]
|
|
[min_aspect _double]
|
|
[max_aspect _double]
|
|
[win_gravity _int]))
|
|
(define-gtk gtk_window_set_geometry_hints (_fun _GtkWindow _GtkWidget _GdkGeometry-pointer _int -> _void))
|
|
|
|
|
|
(define-signal-handler connect-delete "delete-event"
|
|
(_fun _GtkWidget -> _gboolean)
|
|
(lambda (gtk)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(queue-window-event wx (lambda ()
|
|
(unless (other-modal? wx)
|
|
(when (send wx on-close)
|
|
(send wx direct-show #f)))))))))
|
|
|
|
(define-signal-handler connect-configure "configure-event"
|
|
(_fun _GtkWidget _GdkEventConfigure-pointer -> _gboolean)
|
|
(lambda (gtk a)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(send wx remember-size
|
|
(GdkEventConfigure-width a)
|
|
(GdkEventConfigure-height a))))
|
|
#f))
|
|
|
|
(define-cstruct _GdkEventWindowState ([type _int]
|
|
[window _GtkWindow]
|
|
[send_event _int8]
|
|
[changed_mask _int]
|
|
[new_window_state _int]))
|
|
|
|
|
|
(define-signal-handler connect-window-state "window-state-event"
|
|
(_fun _GtkWidget _GdkEventWindowState-pointer -> _gboolean)
|
|
(lambda (gtk evt)
|
|
(let ([wx (gtk->wx gtk)])
|
|
(when wx
|
|
(send wx on-window-state
|
|
(GdkEventWindowState-changed_mask evt)
|
|
(GdkEventWindowState-new_window_state evt))))
|
|
#f))
|
|
|
|
(define-runtime-path plt-16x16-file '(lib "icons/plt-16x16.png"))
|
|
(define-runtime-path plt-32x32-file '(lib "icons/plt-32x32.png"))
|
|
(define-runtime-path plt-48x48-file '(lib "icons/plt-48x48.png"))
|
|
|
|
(define icon-pixbufs+glist
|
|
(delay
|
|
(let ([icons (map
|
|
(lambda (fn)
|
|
(bitmap->pixbuf (make-object bitmap% fn 'png/alpha)))
|
|
(list plt-16x16-file
|
|
plt-32x32-file
|
|
plt-48x48-file))])
|
|
(cons
|
|
;; keep pixbuf pointers to avoid GC:
|
|
icons
|
|
;; a glist:
|
|
(for/fold ([l #f]) ([i (in-list icons)])
|
|
(g_list_insert l i -1))))))
|
|
|
|
;; used for location->window
|
|
(define all-frames (make-hasheq))
|
|
|
|
(define frame%
|
|
(class (client-size-mixin window%)
|
|
(init parent
|
|
label
|
|
x y w h
|
|
style)
|
|
(init [is-dialog? #f])
|
|
|
|
(inherit get-gtk set-size on-size
|
|
pre-on-char pre-on-event
|
|
get-client-delta get-size
|
|
get-parent get-eventspace
|
|
adjust-client-delta
|
|
queue-on-size)
|
|
|
|
(define gtk (as-gtk-window-allocation
|
|
(gtk_window_new GTK_WINDOW_TOPLEVEL)))
|
|
(when (memq 'no-caption style)
|
|
(gtk_window_set_decorated gtk #f))
|
|
(define-values (vbox-gtk panel-gtk)
|
|
(atomically
|
|
(let ([vbox-gtk (gtk_vbox_new #f 0)]
|
|
[panel-gtk (gtk_fixed_new)])
|
|
(gtk_container_add gtk vbox-gtk)
|
|
(gtk_box_pack_end vbox-gtk panel-gtk #t #t 0)
|
|
(values vbox-gtk panel-gtk))))
|
|
(gtk_widget_show vbox-gtk)
|
|
(gtk_widget_show panel-gtk)
|
|
|
|
(unless is-dialog?
|
|
(gtk_window_set_icon_list gtk (cdr (force icon-pixbufs+glist))))
|
|
|
|
(define/override (get-client-gtk) panel-gtk)
|
|
(define/override (get-window-gtk) gtk)
|
|
|
|
(super-new [parent parent]
|
|
[gtk gtk]
|
|
[client-gtk panel-gtk]
|
|
[no-show? #t]
|
|
[add-to-parent? #f]
|
|
[extra-gtks (list panel-gtk)])
|
|
|
|
(set-size x y w h)
|
|
|
|
(when (memq 'hide-menu-bar style)
|
|
(gtk_window_fullscreen gtk))
|
|
|
|
(connect-delete gtk)
|
|
(connect-configure gtk)
|
|
(connect-focus gtk)
|
|
(connect-window-state gtk)
|
|
|
|
(define saved-title (or label ""))
|
|
(define is-modified? #f)
|
|
|
|
(when label
|
|
(gtk_window_set_title gtk label))
|
|
|
|
;(gtk_window_add_accel_group (widget-window gtk) the-accelerator-group)
|
|
|
|
(define/override (set-child-size child-gtk x y w h)
|
|
(gtk_fixed_move panel-gtk child-gtk x y)
|
|
(gtk_widget_set_size_request child-gtk w h))
|
|
|
|
(define/public (on-close) #t)
|
|
|
|
(define/public (set-menu-bar mb)
|
|
(let ([mb-gtk (send mb get-gtk)])
|
|
(gtk_box_pack_start vbox-gtk mb-gtk #t #t 0)
|
|
(gtk_widget_show mb-gtk))
|
|
(let ([h (send mb set-top-window this)])
|
|
;; adjust client delta right away, so that we make
|
|
;; better assumptions about the client size and more
|
|
;; quickly converge to the right size of the frame
|
|
;; based on its content
|
|
(adjust-client-delta 0 h))
|
|
;; Hack: calls back into the mred layer to re-compute
|
|
;; sizes. By calling this early enough, the frame won't
|
|
;; grow if it doesn't have to grow to accomodate the menu bar.
|
|
(send this resized))
|
|
|
|
(define saved-enforcements (vector 0 0 -1 -1))
|
|
|
|
(define/public (enforce-size min-x min-y max-x max-y inc-x inc-y)
|
|
(define (to-max v) (if (= v -1) #x3FFFFF v))
|
|
(set! saved-enforcements (vector min-x min-y max-x max-y))
|
|
(gtk_window_set_geometry_hints gtk gtk
|
|
(make-GdkGeometry min-x min-y
|
|
(to-max max-x) (to-max max-y)
|
|
0 0
|
|
inc-x inc-y
|
|
0.0 0.0
|
|
0)
|
|
(bitwise-ior GDK_HINT_MIN_SIZE
|
|
GDK_HINT_MAX_SIZE
|
|
GDK_HINT_RESIZE_INC)))
|
|
|
|
(define/override (get-top-win) this)
|
|
|
|
(define dc-lock (and (eq? 'windows (system-type)) (make-semaphore 1)))
|
|
(define/public (get-dc-lock) dc-lock)
|
|
|
|
(define/override (get-dialog-level) 0)
|
|
(define/public (frame-relative-dialog-status win) #f)
|
|
|
|
(define/override (get-unset-pos) -11111)
|
|
|
|
(define/override (center dir wrt)
|
|
(let ([w-box (box 0)]
|
|
[h-box (box 0)]
|
|
[sx-box (box 0)]
|
|
[sy-box (box 0)]
|
|
[sw-box (box 0)]
|
|
[sh-box (box 0)])
|
|
(get-size w-box h-box)
|
|
(let ([p (get-parent)])
|
|
(if p
|
|
(begin
|
|
(send p get-size sw-box sh-box)
|
|
(set-box! sx-box (send p get-x))
|
|
(set-box! sy-box (send p get-y)))
|
|
(display-size sw-box sh-box #t)))
|
|
(let* ([sw (unbox sw-box)]
|
|
[sh (unbox sh-box)]
|
|
[fw (unbox w-box)]
|
|
[fh (unbox h-box)])
|
|
(set-top-position (if (or (eq? dir 'both)
|
|
(eq? dir 'horizontal))
|
|
(+ (unbox sx-box) (quotient (- sw fw) 2))
|
|
-11111)
|
|
(if (or (eq? dir 'both)
|
|
(eq? dir 'vertical))
|
|
(+ (unbox sy-box) (quotient (- sh fh) 2))
|
|
-11111)))))
|
|
|
|
(define/public (set-top-position x y)
|
|
(unless (and (= x -11111) (= y -11111))
|
|
(gtk_widget_set_uposition gtk
|
|
(if (= x -11111) -2 x)
|
|
(if (= y -11111) -2 y))))
|
|
|
|
(define/override (really-set-size gtk x y processed-x processed-y w h)
|
|
(set-top-position x y)
|
|
(gtk_window_resize gtk (max 1 w) (max 1 h))
|
|
(queue-on-size))
|
|
|
|
(define/override (show on?)
|
|
(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)
|
|
(define/override (register-child child on?)
|
|
(unless on? (error 'register-child-in-frame "did not expect #f"))
|
|
(unless (or (not saved-child) (eq? child saved-child))
|
|
(error 'register-child-in-frame "expected only one child"))
|
|
(set! saved-child child))
|
|
(define/override (register-child-in-parent on?)
|
|
(void))
|
|
|
|
(define/override (direct-show on?)
|
|
;; atomic mode
|
|
(if on?
|
|
(hash-set! all-frames this #t)
|
|
(hash-remove! all-frames this))
|
|
(super direct-show on?)
|
|
(when on? (gtk_window_deiconify gtk))
|
|
(register-frame-shown this on?))
|
|
|
|
(define/public (destroy)
|
|
;; atomic mode
|
|
(direct-show #f))
|
|
|
|
(define/override (on-client-size w h)
|
|
(void))
|
|
|
|
(define/augment (is-enabled-to-root?) #t)
|
|
|
|
(define big-icon #f)
|
|
(define small-icon #f)
|
|
(define/public (set-icon bm mask [mode 'both])
|
|
(let ([bm (if mask
|
|
(let* ([nbm (make-object bitmap%
|
|
(send bm get-width)
|
|
(send bm get-height)
|
|
#f
|
|
#t)]
|
|
[dc (make-object bitmap-dc% nbm)])
|
|
(send dc draw-bitmap bm 0 0
|
|
'solid (make-object color% "black")
|
|
mask)
|
|
(send dc set-bitmap #f)
|
|
nbm)
|
|
bm)])
|
|
(case mode
|
|
[(small) (set! small-icon bm)]
|
|
[(big) (set! big-icon bm)]
|
|
[(both)
|
|
(set! small-icon bm)
|
|
(set! big-icon bm)])
|
|
(let ([small-pixbuf
|
|
(if small-icon
|
|
(bitmap->pixbuf small-icon)
|
|
(car (car (force icon-pixbufs+glist))))]
|
|
[big-pixbufs
|
|
(if big-icon
|
|
(list (bitmap->pixbuf big-icon))
|
|
(cdr (car (force icon-pixbufs+glist))))])
|
|
(atomically
|
|
(let ([l (for/fold ([l #f]) ([i (cons small-pixbuf
|
|
big-pixbufs)])
|
|
(g_list_insert l i -1))])
|
|
(gtk_window_set_icon_list gtk l)
|
|
(g_list_free l))))))
|
|
|
|
(define child-has-focus? #f)
|
|
(define reported-activate #f)
|
|
(define queued-active? #f)
|
|
(define/public (on-focus-child on?)
|
|
;; atomic mode
|
|
(set! child-has-focus? on?)
|
|
(unless queued-active?
|
|
(set! queued-active? #t)
|
|
(queue-window-event this
|
|
(lambda ()
|
|
(let ([on? child-has-focus?])
|
|
(set! queued-active? #f)
|
|
(unless (eq? on? reported-activate)
|
|
(set! reported-activate on?)
|
|
(on-activate on?)))))))
|
|
|
|
(define/override (call-pre-on-event w e)
|
|
(pre-on-event w e))
|
|
(define/override (call-pre-on-char w e)
|
|
(pre-on-char w e))
|
|
|
|
(define/override (client-to-screen x y)
|
|
(gtk_window_set_gravity gtk GDK_GRAVITY_STATIC)
|
|
(let-values ([(dx dy) (gtk_window_get_position gtk)]
|
|
[(cdx cdy) (get-client-delta)])
|
|
(gtk_window_set_gravity gtk GDK_GRAVITY_NORTH_WEST)
|
|
(set-box! x (+ (unbox x) dx cdx))
|
|
(set-box! y (+ (unbox y) dy cdy))))
|
|
|
|
(define/public (on-toolbar-click) (void))
|
|
(define/public (on-menu-click) (void))
|
|
|
|
(define/public (on-menu-command c) (void))
|
|
|
|
(def/public-unimplemented on-mdi-activate)
|
|
|
|
(define/public (on-activate on?) (void))
|
|
|
|
(define/public (designate-root-frame) (void))
|
|
|
|
(def/public-unimplemented system-menu)
|
|
|
|
(define/public (set-modified mod?)
|
|
(unless (eq? is-modified? (and mod? #t))
|
|
(set! is-modified? (and mod? #t))
|
|
(set-title saved-title)))
|
|
|
|
(define waiting-cursor? #f)
|
|
(define/public (set-wait-cursor-mode on?)
|
|
(set! waiting-cursor? on?)
|
|
(when in-window
|
|
(send in-window enter-window)))
|
|
|
|
(define current-cursor-handle #f)
|
|
(define in-window #f)
|
|
(define/override (set-parent-window-cursor in-win c)
|
|
(set! in-window in-win)
|
|
(let ([c (if waiting-cursor?
|
|
(get-watch-cursor-handle)
|
|
c)])
|
|
(unless (eq? c current-cursor-handle)
|
|
(atomically
|
|
(set! current-cursor-handle c)
|
|
(gdk_window_set_cursor (widget-window (get-gtk)) (if (eq? c (get-arrow-cursor-handle))
|
|
#f
|
|
c))))))
|
|
(define/override (enter-window) (void))
|
|
(define/override (leave-window) (void))
|
|
|
|
(define/override (check-window-cursor win)
|
|
(when in-window
|
|
(send in-window enter-window)))
|
|
|
|
(define maximized? #f)
|
|
(define is-iconized? #f)
|
|
|
|
(define/public (is-maximized?)
|
|
maximized?)
|
|
(define/public (maximize on?)
|
|
((if on? gtk_window_maximize gtk_window_unmaximize) gtk))
|
|
|
|
(define/public (on-window-state changed value)
|
|
(when (positive? (bitwise-and changed GDK_WINDOW_STATE_MAXIMIZED))
|
|
(set! maximized? (positive? (bitwise-and value GDK_WINDOW_STATE_MAXIMIZED))))
|
|
(when (positive? (bitwise-and changed GDK_WINDOW_STATE_ICONIFIED))
|
|
(set! is-iconized? (positive? (bitwise-and value GDK_WINDOW_STATE_ICONIFIED)))))
|
|
|
|
(define/public (iconized?)
|
|
is-iconized?)
|
|
(define/public (iconize on?)
|
|
(if on?
|
|
(gtk_window_iconify gtk)
|
|
(gtk_window_deiconify gtk)))
|
|
|
|
(def/public-unimplemented get-menu-bar)
|
|
|
|
(define/public (set-title s)
|
|
(set! saved-title s)
|
|
(gtk_window_set_title gtk (if is-modified?
|
|
(string-append s "*")
|
|
s)))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-gdk gdk_screen_get_width (_fun _GdkScreen -> _int))
|
|
(define-gdk gdk_screen_get_height (_fun _GdkScreen -> _int))
|
|
|
|
(define (display-origin x y all?) (set-box! x 0) (set-box! y 0))
|
|
(define (display-size w h all?)
|
|
(let ([s (gdk_screen_get_default)])
|
|
(set-box! w (gdk_screen_get_width s))
|
|
(set-box! h (gdk_screen_get_height s))))
|
|
|
|
(define (location->window x y)
|
|
(for/or ([f (in-hash-keys all-frames)])
|
|
(let ([fx (send f get-x)]
|
|
[fw (send f get-width)])
|
|
(and (<= fx x (+ fx fw))
|
|
(let ([fy (send f get-y)]
|
|
[fh (send f get-height)])
|
|
(<= fy y (+ fy fh)))
|
|
f))))
|