152 lines
4.6 KiB
Scheme
152 lines
4.6 KiB
Scheme
(define-record-type key-grab :key-grab
|
|
(make-key-grab window keys message channel override?)
|
|
key-grab?
|
|
(window key-grab:window)
|
|
(keys key-grab:keys)
|
|
(message key-grab:message)
|
|
(channel key-grab:channel)
|
|
(override? key-grab:override?))
|
|
|
|
(define (create-grab-server dpy)
|
|
(let ((in-channel (make-channel)))
|
|
(spawn
|
|
(lambda ()
|
|
(let ((grabs '())
|
|
(event-cache '()))
|
|
(let loop ()
|
|
(let ((msg (receive in-channel)))
|
|
(case (car msg)
|
|
((add-key-grab)
|
|
(let* ((key-grab (second msg))
|
|
(first (car (key-grab:keys key-grab))))
|
|
(set! grabs (cons key-grab grabs))
|
|
(grab-key dpy (key:keycode first)
|
|
(key:modifiers first) (key-grab:window key-grab)
|
|
#f (grab-mode async) (grab-mode async))
|
|
(spawn* (lambda (resume)
|
|
(call-with-event-channel
|
|
dpy (key-grab:window key-grab)
|
|
(event-mask key-press structure-notify)
|
|
(lambda (event-channel)
|
|
(resume)
|
|
(let loop ()
|
|
(let ((e (receive event-channel)))
|
|
(cond
|
|
((destroy-window-event? e)
|
|
(send in-channel (list 'remove-key-grab
|
|
key-grab)))
|
|
((eq? (event-type key-press)
|
|
(any-event-type e))
|
|
(send in-channel (list 'key-press e))
|
|
(loop))
|
|
(else (loop)))))))))))
|
|
((remove-key-grab)
|
|
(let* ((key-grab (second msg))
|
|
(first (car (key-grab:keys key-grab))))
|
|
(if (window-exists? dpy (key-grab:window key-grab))
|
|
(ungrab-key dpy (key:keycode first)
|
|
(key:modifiers first)
|
|
(key-grab:window key-grab)))
|
|
(set! grabs (filter (lambda (g) (not (eq? g key-grab)))
|
|
grabs))))
|
|
((key-press)
|
|
(let ((e (second msg))
|
|
(events (filter (lambda (x) x)
|
|
(map weak-pointer-ref event-cache))))
|
|
;; because more of these can come in a row, we
|
|
;; skip the ones already handled.
|
|
(if (memq e events)
|
|
#f
|
|
(begin
|
|
(set! event-cache
|
|
(map make-weak-pointer (cons e events)))
|
|
(let ((winner (do-grabs dpy grabs e)))
|
|
(if winner
|
|
(send (key-grab:channel winner)
|
|
(list (key-grab:message winner)
|
|
;; this event ??
|
|
(key-event-time e)))))))))
|
|
))
|
|
(loop)))))
|
|
in-channel))
|
|
|
|
(define *grab-server* #f)
|
|
(define *grab-server-lock* (make-lock))
|
|
|
|
(define (grab-shortcut dpy window keys message channel override?)
|
|
;; assert |keys| > 0 ??
|
|
(with-lock *grab-server-lock*
|
|
(lambda ()
|
|
(if (not *grab-server*)
|
|
(set! *grab-server* (create-grab-server dpy)))))
|
|
(let ((key-grab (make-key-grab window keys message channel override?)))
|
|
(send *grab-server* (list 'add-key-grab key-grab))
|
|
key-grab))
|
|
|
|
;; unregister-key ??
|
|
|
|
(define (do-grabs dpy grabs event)
|
|
(let* ((path (reverse (window-path dpy (get-input-focus-window dpy))))
|
|
(grabs (flatten
|
|
(filter
|
|
(lambda (x) x)
|
|
(map (lambda (win)
|
|
(filter
|
|
(lambda (grab)
|
|
(let ((first (car (key-grab:keys grab))))
|
|
(and (equal? win (key-grab:window grab))
|
|
(enum-set=? (key:modifiers first)
|
|
(key-event-state event))
|
|
(equal? (key:keycode first)
|
|
(key-event-keycode event)))))
|
|
grabs))
|
|
path))))
|
|
(grabs-rests (map (lambda (g)
|
|
(cons g (cdr (key-grab:keys g))))
|
|
grabs))
|
|
(winner? (lambda (grabs-rests)
|
|
(let ((dones (map car (filter (lambda (grab-rest)
|
|
(null? (cdr grab-rest)))
|
|
grabs-rests))))
|
|
(mdisplay "winner? dones: " dones "\n")
|
|
(let loop ((dones dones))
|
|
(if (null? dones)
|
|
#f
|
|
(if (or (null? (cdr dones))
|
|
(key-grab:override? (car dones)))
|
|
(car dones)
|
|
(loop (cdr dones)))))))))
|
|
(grab-keyboard dpy (default-root-window dpy) #f
|
|
(grab-mode async) (grab-mode async) ;; ??
|
|
(key-event-time event))
|
|
;; Cursor ?
|
|
(let ((result
|
|
(call-with-event-channel
|
|
dpy (default-root-window dpy) (event-mask key-press)
|
|
(lambda (event-channel)
|
|
(let loop ((grabs-rests grabs-rests))
|
|
(mdisplay "grabs-rests: " grabs-rests "\n")
|
|
(and (not (null? grabs-rests))
|
|
(or (winner? grabs-rests)
|
|
(let ((e (receive event-channel)))
|
|
(cond
|
|
((eq? (event-type key-press)
|
|
(any-event-type e))
|
|
(let ((rest
|
|
(filter
|
|
(lambda (grab-rest)
|
|
(and (not (null? (cdr grab-rest)))
|
|
(let ((next (car (cdr grab-rest))))
|
|
(enum-set=? (key:modifiers next)
|
|
(key-event-state e))
|
|
(equal? (key:keycode next)
|
|
(key-event-keycode e)))))
|
|
grabs-rests)))
|
|
(loop (map (lambda (grab-rest)
|
|
(cons (car grab-rest)
|
|
(cdr (cdr grab-rest))))
|
|
rest))))
|
|
(else (loop grabs-rests)))))))))))
|
|
(ungrab-keyboard dpy current-time)
|
|
result)))
|