141 lines
5.3 KiB
Scheme
141 lines
5.3 KiB
Scheme
;; Thread-safe event reading *****************************************
|
|
|
|
;; wait-event blocks the current thread until an event is available,
|
|
;; and then it returns this new event.
|
|
|
|
(define (wait-event dpy)
|
|
(if (not (> (events-queued dpy (queued-mode after-flush)) 0))
|
|
(block-on-message-inport dpy))
|
|
(next-event dpy))
|
|
|
|
(define (block-on-message-inport dpy) ; needs ports, locks
|
|
(let ((port (display-message-inport dpy)))
|
|
(disable-interrupts!)
|
|
(if (not (char-ready? port))
|
|
(begin
|
|
(obtain-lock (port-lock port))
|
|
(add-pending-channel (port->channel port))
|
|
(wait-for-channel (port->channel port)) ;; enables interrupts
|
|
(release-lock (port-lock port)))
|
|
(enable-interrupts!))))
|
|
|
|
;;; Only here until scsh provides us with select
|
|
(import-lambda-definition add-pending-channel (channel)
|
|
"scx_add_pending_channel")
|
|
|
|
;; How to find out if there are events available *********************
|
|
|
|
(define (event-ready? display)
|
|
(or (> (events-queued display (queued-mode already)) 0)
|
|
(char-ready? (display-message-inport display))))
|
|
|
|
(define (events-queued display mode)
|
|
(%events-queued (display-Xdisplay display)
|
|
(queued-mode->integer mode)))
|
|
|
|
(import-lambda-definition %events-queued (Xdisplay mode)
|
|
"scx_Events_Queued")
|
|
|
|
(define-enumerated-type queued-mode :queued-mode
|
|
queued-mode? queued-modes queued-mode-name queued-mode-index
|
|
(already after-reading after-flush))
|
|
|
|
(define (queued-mode->integer mode)
|
|
(queued-mode-index mode))
|
|
|
|
;; events-pending is identical to events-queued with after-flush
|
|
;; mode.
|
|
|
|
(define (events-pending display)
|
|
(%events-pending (display-Xdisplay display)))
|
|
|
|
(import-lambda-definition %events-pending (Xdisplay)
|
|
"scx_Events_Pending")
|
|
|
|
;; Other event reading ***********************************************
|
|
|
|
(define (next-event display)
|
|
(let ((r (%next-event (display-Xdisplay display))))
|
|
(complete-event r)))
|
|
|
|
(import-lambda-definition %next-event (Xdisplay)
|
|
"scx_Next_Event")
|
|
|
|
(define (peek-event display)
|
|
(let ((r (%peek-event (display-Xdisplay display))))
|
|
(complete-event r)))
|
|
|
|
(import-lambda-definition %peek-event (Xdisplay)
|
|
"scx_Peek_Event")
|
|
|
|
(define (get-motion-events window from-time to-time)
|
|
(%get-motion-events (display-Xdisplay (window-display window))
|
|
(window-Xwindow window)
|
|
from-time to-time))
|
|
|
|
(import-lambda-definition %get-motion-events (Xdisplay Xwindow from to)
|
|
"scx_Get_Motion_Events")
|
|
|
|
;; Sending events ****************************************************
|
|
|
|
(define (send-event display window propagate? event-mask event)
|
|
(let ((Xdisplay (display-Xdisplay display))
|
|
(Xwindow (window-Xwindow window))
|
|
(mask (event-mask->integer event-mask))
|
|
(v (any-event->vector event))
|
|
(type (event-type->integer (any-event-type event))))
|
|
(%send-event Xdisplay Xwindow propagate? mask v type)))
|
|
|
|
(import-lambda-definition %send-event (Xdisplay Xwindow propagate mask v type)
|
|
"scx_Send_Event")
|
|
|
|
;; Auxiliaries *******************************************************
|
|
|
|
;; creates an event type
|
|
|
|
(define (complete-event v)
|
|
(vector-set! v 0 (integer->event-type (vector-ref v 0)))
|
|
(let ((constructor (event-constructor (vector-ref v 0))))
|
|
(apply constructor (vector->list v))))
|
|
|
|
(define (event-constructor type)
|
|
(cond
|
|
((or (eq? type (event-type key-press))
|
|
(eq? type (event-type key-release))) make-key-event)
|
|
((or (eq? type (event-type button-press))
|
|
(eq? type (event-type button-release))) make-button-event)
|
|
((eq? type (event-type motion-notify)) make-motion-event)
|
|
((or (eq? type (event-type enter-notify))
|
|
(eq? type (event-type leave-notify))) make-crossing-event)
|
|
((or (eq? type (event-type focus-in))
|
|
(eq? type (event-type focus-out))) make-focus-change-event)
|
|
((eq? type (event-type keymap-notify)) make-keymap-event)
|
|
((eq? type (event-type expose)) make-expose-event)
|
|
((eq? type (event-type graphics-expose)) make-graphics-expose-event)
|
|
((eq? type (event-type no-expose)) make-no-expose-event)
|
|
((eq? type (event-type visibility-notify)) make-visibility-event)
|
|
((eq? type (event-type create-notify)) make-create-window-event)
|
|
((eq? type (event-type destroy-notify)) make-destroy-window-event)
|
|
((eq? type (event-type unmap-notify)) make-unmap-event)
|
|
((eq? type (event-type map-notify)) make-map-event)
|
|
((eq? type (event-type map-request)) make-map-request-event)
|
|
((eq? type (event-type reparent-notify)) make-reparent-event)
|
|
((eq? type (event-type configure-notify)) make-configure-event)
|
|
((eq? type (event-type configure-request)) make-configure-request-event)
|
|
((eq? type (event-type gravity-notify)) make-gravity-event)
|
|
((eq? type (event-type resize-request)) make-resize-request-event)
|
|
((eq? type (event-type circulate-notify)) make-circulate-event)
|
|
((eq? type (event-type circulate-request)) make-circulate-request-event)
|
|
((eq? type (event-type property-notify)) make-property-event)
|
|
((eq? type (event-type selection-clear)) make-selection-clear-event)
|
|
((eq? type (event-type selection-request)) make-selection-request-event)
|
|
((eq? type (event-type selection-notify)) make-selection-event)
|
|
((eq? type (event-type colormap-notify)) make-colormap-event)
|
|
((eq? type (event-type client-message)) make-client-message-event)
|
|
((eq? type (event-type mapping-notify)) make-mapping-event)
|
|
(else (error "message type not supported" type))))
|
|
|
|
;;event-type-0 event-type-1 ;; those are not defined
|
|
|
|
|