[add] can now hold many event handlers on a single listener

1 files changed, 59 insertions, 36 deletions

diff --git a/wheelwork.lisp b/wheelwork.lisp
index b4149ff..37a7bfc 100644
--- a/wheelwork.lisp
+++ b/wheelwork.lisp
@@ -128,16 +128,19 @@ necessary."
 
 (defmethod drop-unit :before ((unit interactive))
   (when (unit-container unit) 
-    (when-let (handler (get-handler-for unit 'before-dropped))
-      (funcall handler 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 (handler (get-handler-for unit 'before-added))
-    (funcall handler container unit)))
+  (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 (handler (get-handler-for unit 'after-added))
-    (funcall handler container unit)))
+  (when-let (handlers (get-handlers-for unit 'after-added))
+    (dolist (handler handlers) 
+      (funcall handler container unit))))
 
 (defun listener-table-for (listener event-type)
   (ecase event-type
@@ -158,21 +161,33 @@ necessary."
 (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
-   (slot-value (listener interactive) (event-type handler))        handler
-   (gethash interactive (listener-table-for (listener interactive) (event-type handler))) handler))
+   (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."
+  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) nil)
-      (remhash interactive (listener-table-for (listener interactive) 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))))))
 
 
 
@@ -219,12 +234,14 @@ necessary."
   (setf (listener app) (make-instance 'listener)))
 
 (defun fire-blur-event-on (thing)
-  (when-let (blur-handler (and thing (get-handler-for thing 'blur)))
-    (funcall blur-handler thing)))
+  (when-let (blur-handlers (and thing (get-handlers-for thing 'blur)))
+    (dolist (handler blur-handlers) 
+      (funcall handler thing))))
 
 (defun fire-focus-event-on (thing)
-  (when-let (focus-handler (and thing (get-handler-for thing 'focus)))
-    (funcall focus-handler thing)))
+  (when-let (focus-handlers (and thing (get-handlers-for thing 'focus)))
+    (dolist (handler focus-handlers)
+      (funcall handler thing))))
 
 (defmethod (setf closer-mop:slot-value-using-class ) :before
     (new-value class (app application) slot)
@@ -310,8 +327,8 @@ necessary."
   (let ((table (perframe-table (listener app)))
         (time (get-universal-time)))
     (loop for target being the hash-key of table
-          for handler being the hash-value of table
-          do (funcall handler target time)))
+          for handlers = (slot-value (listener target) 'perframe)
+          do (loop for handler in handlers do (funcall handler target time))))
   (gl:clear-color 0.0 0.0 0.0 1.0)
   (gl:clear :depth-buffer-bit :color-buffer-bit)
   (dolist (thing (container-units app))
@@ -415,25 +432,27 @@ TARGET is FOCUSABLEP"
 (defun get-focus (&optional (app *application*))
   (or (application-focus app) app))
 
-(defun get-handler-for (unit event-type)
+(defun get-handlers-for (unit event-type)
   "EVENT-TYPE must be one of the slot value names for WHEELWORK::LISTENER."
   (?> (unit) listener #$(slot-value $listener event-type)))
 
 (defun eventloop-keydown (app sdl-keysym)
   (let ((target (get-focus app))) 
-    (when-let (handler (get-handler-for target 'keydown)) 
-      (apply handler
-             target
-             (sdl2:scancode sdl-keysym)
-             (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))
+    (when-let (handlers (get-handlers-for target 'keydown)) 
+      (dolist (handler handlers) 
+        (apply handler
+               target
+               (sdl2:scancode sdl-keysym)
+               (sdl2:mod-keywords (sdl2:mod-value sdl-keysym)))))))
 
 (defun eventloop-keyup (app sdl-keysym)
   (let ((target (get-focus app))) 
-    (when-let (handler (get-handler-for target 'keyup)) 
-      (apply handler
-             target
-             (sdl2:scancode sdl-keysym)
-             (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))
+    (when-let (handlers (get-handlers-for target 'keyup)) 
+      (dolist (handler handlers) 
+        (apply handler
+               target
+               (sdl2:scancode sdl-keysym)
+               (sdl2:mod-keywords (sdl2:mod-value sdl-keysym)))))))
 
 (defun contains-point-p (unit px py)
   (with-accessors ((x unit-x) (y unit-y) (width unit-width) (height unit-height)) unit
@@ -466,16 +485,18 @@ give focus to whatever was clicked."
                 app)))                  ; then target the app itself
       (when (and (refocus-on-mousedown-p app) (focusablep target))
         (refocus-on target))              
-      (when-let (handler (get-handler-for target 'mousedown))
-        (funcall handler target x y clicks button wx wy)))))
+      (when-let (handlers (get-handlers-for target 'mousedown))
+        (dolist (handler handlers) 
+          (funcall handler target x y clicks button wx wy))))))
 
 (defun eventloop-mousebuttonup (app wx wy clicks button)
   (when (should-listen-for-p 'mouseup app)
     (destructuring-bind (x y) (screen-to-world wx wy)
       (when-let* ((target (or (unit-under app x y)
                               app))
-                  (handler (get-handler-for target 'mouseup)))
-        (funcall handler target x y clicks button wx wy)))))
+                  (handlers (get-handlers-for target 'mouseup)))
+        (dolist (handler handlers) 
+          (funcall handler target x y clicks button wx wy))))))
 
 (defun eventloop-mousemotion (app wx wy wxrel wyrel state)
   (when (should-listen-for-p 'mousemotion app)
@@ -483,14 +504,16 @@ give focus to whatever was clicked."
       (destructuring-bind (xrel yrel) (screen-to-world wxrel wyrel)
         (when-let* ((target (or (unit-under app x y)
                                 app))
-                    (handler (get-handler-for target 'mousemotion)))
-          (funcall handler target x y xrel yrel state wx wy wxrel wyrel))))))
+                    (handlers (get-handlers-for target 'mousemotion)))
+          (dolist (handler handlers) 
+            (funcall handler target x y xrel yrel state wx wy wxrel wyrel)))))))
 
 (defun eventloop-mousewheel (app wx wy dir)
   (when (should-listen-for-p 'mousewheel app)
     (when-let* ((focus (get-focus app))
-                (handler (get-handler-for focus 'mousewheel)))
-      (funcall handler focus wx wy dir))))
+                (handlers (get-handlers-for focus 'mousewheel)))
+      (dolist (handler handlers) 
+        (funcall handler focus wx wy dir)))))
 
 
 (defun eventloop (app)