diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/events/event-handler.lisp | 35 | ||||
| -rw-r--r-- | src/interactive/interactive.lisp | 35 |
2 files changed, 46 insertions, 24 deletions
diff --git a/src/events/event-handler.lisp b/src/events/event-handler.lisp index 9d48aea..a88f63d 100644 --- a/src/events/event-handler.lisp +++ b/src/events/event-handler.lisp @@ -4,7 +4,7 @@ (defclass/std event-handler () - ((event-type handler-function :ri)) + ((event-type handler-function tag :ri)) (:metaclass closer-mop:funcallable-standard-class)) (defmethod initialize-instance :after ((eh event-handler) &key) @@ -24,6 +24,15 @@ can be redefined using this form to support interactive development." (closer-mop:set-funcallable-instance-function extant (handler-function ,handler-var)) (setf (fdefinition ',name) ,handler-var))))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun get-tag-from-handler-body (body) + (when (eq (first body) :tag) + (second body))) + + (defun get-body-from-handler-body (body) + (if (get-tag-from-handler-body body) + (nthcdr 2 body) + body))) (defmacro on-perframe ((&optional (target 'target) (time 'time)) &body body) @@ -39,12 +48,13 @@ can be redefined using this form to support interactive development." " `(make-instance 'event-handler + :tag ,(get-tag-from-handler-body body) :event-type 'wheelwork::perframe :handler-function (lambda (,(intern (symbol-name target)) ,(intern (symbol-name time))) (declare (ignorable ,(intern (symbol-name target)) ,(time (intern (symbol-name time))))) - ,@body))) + ,@(get-body-from-handler-body body)))) (defmacro on-keydown ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body) @@ -64,6 +74,7 @@ can be redefined using this form to support interactive development." The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc" `(make-instance 'event-handler + :tag ,(get-tag-from-handler-body body) :event-type 'wheelwork::keydown :handler-function (lambda (,(intern (symbol-name target)) ,(intern (symbol-name scancode)) @@ -71,7 +82,7 @@ can be redefined using this form to support interactive development." (declare (ignorable ,(intern (symbol-name target)) ,(intern (symbol-name scancode)) ,(intern (symbol-name modifiers)))) - ,@body))) + ,@(get-body-from-handler-body body)))) (defmacro on-keyup ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body) @@ -92,6 +103,7 @@ can be redefined using this form to support interactive development." The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc" `(make-instance 'event-handler + :tag ,(get-tag-from-handler-body body) :event-type 'wheelwork::keyup :handler-function (lambda (,(intern (symbol-name target)) ,(intern (symbol-name scancode)) @@ -99,7 +111,7 @@ can be redefined using this form to support interactive development." (declare (ignorable ,(intern (symbol-name target)) ,(intern (symbol-name scancode)) ,(intern (symbol-name modifiers)))) - ,@body))) + ,@(get-body-from-handler-body body)))) (defmacro on-mousemotion ((&optional @@ -127,6 +139,7 @@ can be redefined using this form to support interactive development." `(make-instance 'event-handler + :tag ,(get-tag-from-handler-body body) :event-type 'wheelwork::mousemotion :handler-function (lambda (,(intern (symbol-name target)) ,(intern (symbol-name x)) @@ -148,7 +161,7 @@ can be redefined using this form to support interactive development." ,(intern (symbol-name win-y)) ,(intern (symbol-name win-xrel)) ,(intern (symbol-name win-yrel)))) - ,@body))) + ,@(get-body-from-handler-body body)))) (defmacro on-mousedown ((&optional (target 'target) @@ -171,6 +184,7 @@ can be redefined using this form to support interactive development." " `(make-instance 'event-handler + :tag ,(get-tag-from-handler-body body) :event-type 'wheelwork::mousedown :handler-function (lambda (,(intern (symbol-name target)) @@ -188,7 +202,7 @@ can be redefined using this form to support interactive development." ,(intern (symbol-name button)) ,(intern (symbol-name win-x)) ,(intern (symbol-name win-y)))) - ,@body))) + ,@(get-body-from-handler-body body)))) (defmacro on-mouseup ((&optional (target 'target) @@ -212,6 +226,7 @@ can be redefined using this form to support interactive development." " `(make-instance 'event-handler + :tag ,(get-tag-from-handler-body body) :event-type 'wheelwork::mouseup :handler-function (lambda (,(intern (symbol-name target)) @@ -229,7 +244,7 @@ can be redefined using this form to support interactive development." ,(intern (symbol-name button)) ,(intern (symbol-name win-x)) ,(intern (symbol-name win-y)))) - ,@body))) + ,@(get-body-from-handler-body body)))) (defmacro on-mousewheel ((&optional (target 'target) (horiz 'horiz) (vert 'vert) (dir 'dir)) &body body) @@ -273,12 +288,13 @@ fires whenever an object loses focus. " `(make-instance 'event-handler + :tag ,(get-tag-from-handler-body body) :event-type 'wheelwork::blur :handler-function (lambda (,(intern (symbol-name target))) (declare (ignorable ,(intern (symbol-name target)))) - ,@body))) + ,@(get-body-from-handler-body body)))) (defmacro on-focus ((&optional (target 'target)) &body body) @@ -293,9 +309,10 @@ fires when the FOCUS slot of the current APPLICATION instance is changed. " `(make-instance 'event-handler + :tag ,(get-tag-from-handler-body body) :event-type 'wheelwork::focus :handler-function (lambda (,(intern (symbol-name target))) (declare (ignorable ,(intern (symbol-name target)))) - ,@body))) + ,@(get-body-from-handler-body body)))) diff --git a/src/interactive/interactive.lisp b/src/interactive/interactive.lisp index 6152c3e..ceacf1b 100644 --- a/src/interactive/interactive.lisp +++ b/src/interactive/interactive.lisp @@ -19,24 +19,29 @@ ON-* Macros." 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." +(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 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))))) + (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) - (if (symbolp handler-or-event-type) - ;; remove everything if a symbol - nil - ;; delete just the handler - (delete handler-or-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))) + :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)))))) |