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