blob: 11bc5cafaed63bca9116cacbcc431e7d9b1edb57 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
;;;; interactive.lisp
(in-package #:wheelwork)
(defclass/std interactive ()
((listener :type (or null listener) :std nil :a)
(focusablep :std t :doc "Whether or not this object can receive application focus."))
(:documentation "Supplies an object with a listener slot."))
(defun remove-all-handlers (interactive)
(loop
for type in '(keydown keyup mousedown mouseup mousemotion mousewheel focus blur perframe)
do (remove-handler interactive type)))
(defmethod cleanup :after ((ob interactive))
(remove-all-handlers ob))
(defun add-handler (interactive handler)
"Adds HANDLER to INTERACTIVE. HANDLER is an instance of
WHEELWORK::EVENT-HANDLER, as most readily constructed by using the
ON-* Macros."
(when (null (listener interactive))
(setf (listener interactive) (make-instance 'listener)))
(pushnew handler (slot-value (listener interactive) (event-type handler)) :test #'eq)
(setf
(gethash interactive (listener-table-for (listener interactive) (event-type handler)))
t))
(defun remove-handler (interactive thing &key tag)
"THING can be an instance of EVENT-HANDLER or can be a symbol whose
name is an event type. If is an event handler, only that handler
will be removed. If it is an event type, and if TAG is NIL, then all
events of that type name are removed from the object. Otherwise,
just the event with the provided TAG is removed. If no such tag is
found, none are removed."
(when (listener interactive)
(let ((event-type (etypecase thing
(keyword (intern (symbol-name thing) :wheelwork))
(symbol (intern (symbol-name thing) :wheelwork))
(event-handler (event-type thing)))))
(setf (slot-value (listener interactive) event-type)
(cond
((and (symbolp thing) tag)
(delete-if (lambda (h) (equal (tag h) tag))
(slot-value (listener interactive) event-type)))
((symbolp thing)
nil)
(t
(delete thing
(slot-value (listener interactive) event-type)
:test #'eq))))
;; remove from from the global table unless any listeners remain on this event
(unless (slot-value (listener interactive) event-type)
(remhash interactive (listener-table-for (listener interactive) event-type))))))
|
