#lang racket/base
(require racket/class
ffi/unsafe
"utils.rkt"
"types.rkt"
"../../lock.rkt"
"../common/queue.rkt"
"../common/freeze.rkt"
"clipboard.rkt"
"const.rkt"
"w32.rkt"
"unique.rkt"
"../common/keep-forever.rkt")
(provide (protect-out gtk-start-event-pump
try-to-sync-refresh
set-widget-hook!
x11-display)
;; from common/queue:
current-eventspace
queue-event
yield)
;; ------------------------------------------------------------
;; Gtk initialization
;; When IBus is used for GtkIMContext (see "canvas.rkt"), recent
;; versions may use a asynchronous mode that somehow doesn't
;; cooperate with `g_main_context_query` Specifically, the
;; asynchronous result doesn't wake up a sleeping Racket main
;; thread, and so the effect of a key is delayed. The following
;; enviornment variable is consulted by IBus on startup to
;; disable asynchronous mode.
(void (putenv "IBUS_ENABLE_SYNC_MODE" "y"))
(define-gtk gtk_init_check (_fun (_ptr io _int) (_ptr io _gcpointer) -> _gboolean))
(define-gdk gdk_set_program_class (_fun _string -> _void))
(define x11-display
(let* ([argc-ptr (scheme_register_process_global "PLT_X11_ARGUMENT_COUNT" #f)]
[argc (or (and argc-ptr (cast argc-ptr _pointer _long)) 0)]
[argv (and (positive? argc)
(scheme_register_process_global "PLT_X11_ARGUMENTS" #f))]
[display (getenv "DISPLAY")])
;; Convert X11 arguments, if any, to Gtk form:
(let-values ([(args single-instance?)
(if (zero? argc)
(values null #f)
(let loop ([i 1][si? #f])
(if (= i argc)
(values null si?)
(let ([s (ptr-ref argv _bytes i)])
(cond
[(bytes=? s #"-display")
(let-values ([(args si?) (loop (+ i 2) si?)]
[(d) (ptr-ref argv _bytes (add1 i))])
(set! display (bytes->string/utf-8 d #\?))
(values (list* #"--display" d args)
si?))]
[(bytes=? s #"-synchronous")
(let-values ([(args si?) (loop (+ i 1) si?)])
(values (cons #"--sync" args)
si?))]
[(bytes=? s #"-singleInstance")
(loop (add1 i) #t)]
[(or (bytes=? s #"-iconic")
(bytes=? s #"-rv")
(bytes=? s #"+rv")
(bytes=? s #"-reverse"))
;; ignored with 0 arguments
(loop (add1 i) #t)]
[else
;; all other ignored flags have a single argument
(loop (+ i 2) #t)])))))])
(let-values ([(new-argc new-argv)
(values (add1 (length args))
(cast (cons (path->bytes (find-system-path 'run-file))
args)
(_list i _bytes)
_pointer))])
(unless (gtk_init_check new-argc new-argv)
(error (format
"Gtk initialization failed for display ~s"
(or display ":0"))))
(when single-instance?
(do-single-instance))
(let ([v (scheme_register_process_global "Racket-GUI-wm-class" #f)])
(when v
(gdk_set_program_class (cast v _pointer _string))))
display))))
;; ------------------------------------------------------------
;; Gtk event pump
(define-gtk gtk_events_pending (_fun -> _gboolean))
(define-gtk gtk_main_iteration_do (_fun _gboolean -> _gboolean))
(define _GMainContext (_cpointer 'GMainContext))
(define _GdkEvent (_cpointer 'GdkEvent))
(define-cstruct _GPollFD ([fd _int]
[events _short]
[revents _short]))
(define-glib g_main_context_default (_fun -> _GMainContext))
(define-glib g_main_context_query (_fun _GMainContext
_int
_pointer
_pointer ;; GPollFD array
_int
-> _int))
(define-gdk gdk_event_handler_set (_fun (_fun _GdkEvent _pointer -> _void)
_pointer
(_fun _pointer -> _void)
-> _void))
(define-gdk gdk_event_copy (_fun _GdkEvent -> _GdkEvent))
(define-gdk gdk_event_free (_fun _GdkEvent -> _void))
(define-gtk gtk_main_do_event (_fun _GdkEvent -> _void))
(define-gtk gtk_get_event_widget (_fun _GdkEvent -> (_or-null _GtkWidget)))
(define poll-fd-count 1)
(define poll-fds (make-GPollFD 0 0 0))
(define timeout (malloc _int))
;; These are OS-specific, but they tend to be the same across OSes:
(define POLLIN #x1)
(define POLLOUT #x4)
(define POLLERR #x8)
(define POLLHUP #x10)
(define-mz scheme_get_fdset (_fun _pointer _int -> _gcpointer))
(define-mz scheme_fdset (_fun _gcpointer _int -> _void))
(define-mz scheme_set_wakeup_time (_fun _gcpointer _double -> _void))
(define-mz scheme_add_fd_eventmask (_fun _gcpointer _int -> _void)
#:fail #f)
(define (install-wakeup fds)
(let ([n (g_main_context_query (g_main_context_default)
#x7FFFFFFF ; max-int, hopefully
timeout
poll-fds
poll-fd-count)])
(let ([to (ptr-ref timeout _int)])
(when (to . >= . 0)
(scheme_set_wakeup_time fds (+ (current-inexact-milliseconds) to))))
(if (n . > . poll-fd-count)
(begin
(set! poll-fds (malloc _GPollFD n))
(set! poll-fd-count n)
(install-wakeup fds))
(if (eq? 'windows (system-type))
;; We don't know how to deal with GLib FDs under
;; Windows, but we should wake up on any Windows event
(scheme_add_fd_eventmask fds QS_ALLINPUT)
;; Normal FD handling under Unix variants:
(for ([i (in-range n)])
(let* ([gfd (ptr-ref poll-fds _GPollFD i)]
[fd (GPollFD-fd gfd)]
[events (GPollFD-events gfd)])
(when (not (zero? (bitwise-and events POLLIN)))
(scheme_fdset (scheme_get_fdset fds 0) fd))
(when (not (zero? (bitwise-and events POLLOUT)))
(scheme_fdset (scheme_get_fdset fds 1) fd))
(when (not (zero? (bitwise-and events (bitwise-ior POLLERR POLLHUP))))
(scheme_fdset (scheme_get_fdset fds 2) fd))))))))
(set-check-queue! gtk_events_pending)
(set-queue-wakeup! install-wakeup)
(define widget-hook (lambda (gtk) #f))
(define (set-widget-hook! proc) (set! widget-hook proc))
(define (event-dispatch evt ignored)
(let* ([gtk (gtk_get_event_widget evt)]
[wx (and gtk (widget-hook gtk))])
(cond
[(and (= (ptr-ref evt _GdkEventType) GDK_EXPOSE)
wx
(send wx direct-update?))
(gtk_main_do_event evt)]
[(or
;; event for a window that we control?
(and wx (send wx get-eventspace))
;; event to get X selection data?
(and (= (ptr-ref evt _GdkEventType) GDK_SELECTION_REQUEST)
(let ([s (cast evt _pointer _GdkEventSelection-pointer)])
(= (GdkEventSelection-selection s)
(get-primary-atom)))
(get-selection-eventspace)))
=> (lambda (e)
(let ([evt (gdk_event_copy evt)])
(queue-event e (lambda ()
(call-as-nonatomic-retry-point
(lambda ()
(gtk_main_do_event evt)
(gdk_event_free evt)))))))]
[else
(gtk_main_do_event evt)])))
(define (uninstall ignored)
(printf "uninstalled!?\n"))
(gdk_event_handler_set event-dispatch
#f
uninstall)
(keep-forever event-dispatch)
(keep-forever uninstall)
(define (dispatch-all-ready)
(pre-event-sync #f)
(clean-up-destroyed)
(when (gtk_events_pending)
(gtk_main_iteration_do #f)
(dispatch-all-ready)))
(define-gdk gdk_window_process_all_updates (_fun -> _void))
(define (gtk-start-event-pump)
(thread (lambda ()
(let loop ()
(unless (let ([any-tasks? (sync/timeout 0 boundary-tasks-ready-evt)])
(sync/timeout (and any-tasks? (* sometimes-delay-msec 0.001))
queue-evt
(if any-tasks?
(wrap-evt (system-idle-evt)
(lambda (v) #f))
boundary-tasks-ready-evt)))
(pre-event-sync #t))
(atomically (dispatch-all-ready))
(loop)))))
(define (try-to-sync-refresh)
(atomically
(pre-event-sync #t)))