blob: a8fa7fd2391e9ce4546362e16a2ff48088dfb969 (
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
|
;;;; 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 add-handler (interactive handler)
(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 handler-or-event-type)
"Handler 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, all events of that
type name are removed from the object."
(when (listener interactive)
(let ((event-type (etypecase handler-or-event-type
(keyword (intern (symbol-name handler-or-event-type) :wheelwork))
(symbol (intern (symbol-name handler-or-event-type) :wheelwork))
(event-handler (event-type handler-or-event-type)))))
(setf (slot-value (listener interactive) event-type)
(if (symbolp handler-or-event-type)
;; remove everything if a symbol
nil
;; delete just the handler
(delete handler-or-event-type
(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))))))
(defmethod drop-unit :before ((unit interactive))
(when (unit-container unit)
(when-let (handlers (get-handlers-for unit 'before-dropped))
(dolist (handler handlers)
(funcall handler unit)))))
(defmethod add-unit :before ((container container) (unit interactive))
(when-let (handlers (get-handlers-for unit 'before-added))
(dolist (handler handlers)
(funcall handler container unit))))
(defmethod add-unit :after ((container container) (unit interactive))
(when-let (handlers (get-handlers-for unit 'after-added))
(dolist (handler handlers)
(funcall handler container unit))))
|
