aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--gui/menus.lisp2
-rw-r--r--src/events/event-handler.lisp35
-rw-r--r--src/interactive/interactive.lisp35
3 files changed, 47 insertions, 25 deletions
diff --git a/gui/menus.lisp b/gui/menus.lisp
index 6c3e5b8..0e51aba 100644
--- a/gui/menus.lisp
+++ b/gui/menus.lisp
@@ -59,7 +59,7 @@
(defgeneric add-menu-item (menu item))
(defmethod add-menu-item ((menu menu) item)
(setf (unit-region item) (unit-region menu)
- (focusablep item) nil)
+ (focusablep item) nil) ; so that event handling here doesn't steal menu focus
(setf (menu-items menu)
(nconc (menu-items menu) (list item)))
(when (unit-in-scene-p menu)
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))))))