1;; events.jl 2 3;; Copyright (C) 2011, hqwrong <hq.wrong@gmail.com> 4 5;; This file is part of sawfish. 6 7;; This program is free software: you can redistribute it and/or modify 8;; it under the terms of the GNU General Public License as published by 9;; the Free Software Foundation, either version 3 of the License, or (at 10;; your option) any later version. 11 12;; This program is distributed in the hope that it will be useful, but 13;; WITHOUT ANY WARRANTY; without even the implied warranty of 14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15;; General Public License for more details. 16 17;; You should have received a copy of the GNU General Public License 18;; along with this program. If not, see `http://www.gnu.org/licenses/'. 19 20 21(define-structure sawfish.wm.util.events 22 23 (export event-wait-for 24 event-exit-wait) 25 26 (open rep 27 rep.data 28 rep.system 29 rep.regexp 30 sawfish.wm.misc 31 sawfish.wm.events 32 sawfish.wm.commands) 33 34 (define (event-wait-for #!key 35 (keymap '(keymap)) 36 loop-on-unbound 37 handler 38 exit-hook) 39 "wait-for an event. 40`keymap' is used as the override keymap during `recursive-edit' 41 42`handler' is a list of cons cell,as (predict 43. procedure), when the key event has no bound in keymap, then the 44key name is passed to each predict by order.Once eval to t ,then 45the associated procedure is called with key as argument,then 46re-enter in `recursive-edit'.Otherwise,if loop-on-unbound is nil, 47exit loop. 48 49`exit-hook' ,if setted,will be called with key's name as argument, 50after exit from loop." 51 52 (call-with-keyboard-grabbed 53 (lambda () 54 (let ((override-keymap keymap) 55 (re-exit (lambda () 56 (throw 're-exit 57 (event-name (current-event))))) 58 (key nil)) 59 (add-hook 'unbound-key-hook re-exit) 60 (while (catch 'event-exit 61 (setq key 62 (catch 're-exit 63 (recursive-edit))) 64 (when handler 65 (do ((l handler (cdr handler))) 66 ((null l) t) 67 (let* ((cell (car l)) 68 (pred (car cell)) 69 (proc (cdr cell))) 70 (when (pred key) 71 (proc key) 72 (throw 'event-exit t))))) 73 (when (not loop-on-unbound) 74 (throw 'event-exit nil)) 75 t) 76 t) 77 (when exit-hook 78 (exit-hook key)) 79 (remove-hook 'unbound-key-hook re-exit))))) 80 81 (define (event-exit-wait) 82 "You'll find it useful,when you're using `event-wait-for'" 83 (throw 'event-exit))) 84