Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/input In directory common-lisp.net:/tmp/cvs-serv24047/beagle/input

Modified Files: events.lisp Log Message: Some refactoring of events.lisp; made an effort to trawl for memory allocations and ensure they're freed appropriately. Estimate this to be around 70-80% done. Seems to give performance and stability benefits.

Date: Fri May 20 00:25:34 2005 Author: drose

Index: mcclim/Backends/beagle/input/events.lisp diff -u mcclim/Backends/beagle/input/events.lisp:1.3 mcclim/Backends/beagle/input/events.lisp:1.4 --- mcclim/Backends/beagle/input/events.lisp:1.3 Tue May 17 22:12:37 2005 +++ mcclim/Backends/beagle/input/events.lisp Fri May 20 00:25:34 2005 @@ -28,7 +28,7 @@

#||

-$Id: events.lisp,v 1.3 2005/05/17 20:12:37 drose Exp $ +$Id: events.lisp,v 1.4 2005/05/19 22:25:34 drose Exp $

All these are copied pretty much from CLX/port.lisp

@@ -56,19 +56,19 @@ ;;; The following parameters are *all* added for 'synthesize-pointer-motion-event' only.

(defparameter *-current-event-modifier-state-* 0 - "Contains the most recent modifier state for any ``real'' event. Reset whenever any + "Contains the most recent modifier state for any 'real' event. Reset whenever any event (but not notification) is handled.") (defparameter *-current-pointer-button-state-* 0 - "Contains the most recent pointer button state for any ``real'' event. Reset whenever + "Contains the most recent pointer button state for any 'real' event. Reset whenever any pointer or button-press event is handled.") (defparameter *-current-pointer-graft-xy-* nil "Contains the (Cocoa) NSPoint foreign object (structure) representing the position of -the mouse pointer in screen coordinates. Reset whenever a ``real'' pointer event +the mouse pointer in screen coordinates. Reset whenever a 'real' pointer event (mouse-move, mouse-drag, enter / exit or button press / release) is handled.") (defparameter *-current-pointer-view-xy-* nil "Contains the (Cocoa) NSPoint foreign object (structure) representing the position of the mouse pointer in the coordinate system of the NSView it is currently over. Reset -whenever a ``real'' pointer event (mouse-move, mouse-drag, enter / exit or button +whenever a 'real' pointer event (mouse-move, mouse-drag, enter / exit or button press / release) is handled.")

(defvar *keysym-hash-table* @@ -104,17 +104,6 @@ ;;; in cocoa (grab events and window hints), hopefully that won't matter to ;;; us (apart from the menus use grabbing I think)

-;;; All these parameters must be what CLX provides for the :handler argument -;;; to the xlib:process-event method. - -;;; We don't actually need all this gubbins for Cocoa events. We just need a -;;; method to convert from a Cocoa event to a CLIM event. As specified, this -;;; would be quite a good fit. Unfortunately, McCLIM seems to have a whole -;;; bunch of non-standard slots in the event objects (root-x, root-y etc.) -;;; and the override-redirect-p, send-event-p, hint-p stuff in this method. - -;;; So we actually want to do this slightly differently. - ;; From CLX/port.lisp

;; NOTE: Although it might be tempting to compress (consolidate) @@ -136,31 +125,6 @@ ;; ;;--GB

-;; XXX :button code -> :button (decode-x-button-code code) -;; (declare (ignorable event-slots)) -;; (declare (special *cocoa-port*)) -;; (let ((sheet (and window -;; (port-lookup-sheet port window)))) -;; (when sheet -;; (:enter-notify -;; (make-instance 'pointer-enter-event -;; :pointer 0 -;; :button code :x x :y y -;; :graft-x root-x -;; :graft-y root-y -;; :sheet sheet -;; :modifier-state (cocoa-event-state-modifiers *cocoa-port* state) -;; :timestamp time)) -;; (:leave-notify -;; (make-instance 'pointer-exit-event ; No grab events in cocoa - may cause problems? -;; :pointer 0 -;; :button code -;; :x x :y y -;; :graft-x root-x -;; :graft-y root-y -;; :sheet sheet -;; :modifier-state (cocoa-event-state-modifiers *cocoa-port* state) -;; :timestamp time))

(defparameter *mcclim-event-queue* nil)

@@ -176,7 +140,8 @@ (setf *mcclim-event-queue* (nconc *mcclim-event-queue* (list clim-event))) (ccl:signal-semaphore (beagle-port-event-semaphore *beagle-port*)))))

-(defmethod add-notification-to-queue (window notification &optional origin-x origin-y width height) +(defmethod add-notification-to-queue (window notification + &optional origin-x origin-y width height) "Adds an event to the dynamically scoped *mcclim-event-queue* queue, after conversion from a Cocoa notification MACPTR to a CLIM event. This method signals the port event semaphore when a notification is added to the queue." @@ -224,14 +189,16 @@ ;; Can we make use of the other modifier states set by cocoa? Some of ;; them might be useful...

-;;; Every key on the keyboard has a physical "key-code". a and A share the same key code, since the -;;; same key is pressed (0 in this case). We can't make use of the key-code with any confidence since -;;; they're at a very low-level. We have to use the 'characters method (or 'characters-ignoring-modifiers) -;;; to pull the actual keys out of the event. Then we need to map these to McCLIM key names. *sigh* - -;;; We could use 'characters if we were going through the full Cocoa key-handling path; and we might -;;; be able to make use of this anyway, but for now just use 'characters-ignoring-modifiers and compare -;;; what we get with those values known from Cocoa for function keys etc. +;;; Every key on the keyboard has a physical "key-code". a and A share the same key +;;; code, since the same key is pressed (0 in this case). We can't make use of the +;;; key-code with any confidence since they're at a very low-level. We have to use +;;; the 'characters method (or 'characters-ignoring-modifiers) to pull the actual +;;; keys out of the event. Then we need to map these to McCLIM key names. *sigh* + +;;; We could use 'characters if we were going through the full Cocoa key-handling +;;; path; and we might be able to make use of this anyway, but for now just use +;;; 'characters-ignoring-modifiers and compare what we get with those values known +;;; from Cocoa for function keys etc. (defun beagle-key-event-to-key-name (event) ;; This falls over when the function keys, the arrow keys, the num-lock key (and others) ;; are pressed; I guess we don't want to be doing this! @@ -240,6 +207,7 @@ ;;; (format *terminal-io* "returning key-name: ~A~%" key-name) key-name))

+;;; ::TODO:: - make these masks parameters so the user can configure them? (defun beagle-modifier-to-modifier-state (flags) (declare (special *-current-event-modifier-state-*)) (let ((mods 0)) @@ -262,6 +230,9 @@ ;;; NSHelpKeyMask ;;; NSNumericKeyPadKeyMask (key on numeric pad was pressed) ;;; NSFunctionKeyMask (function key was pressed) + + ;; ::TODO:: return from setf is the value set, so don't need + ;; the final line below. (setf *-current-event-modifier-state-* mods) mods))

@@ -295,14 +266,104 @@

;; I'm not sure this is the best way with dealing with the timestamp...

+(defun notification-type (notification) +"Enumerates all the Cocoa notifications Beagle takes an interest in. These +are all NSWindow delegate notifications." + (let ((name (send notification 'name))) + (cond ((send name :is-equal-to-string #@"NSWindowDidBecomeKeyNotification") + :became-key) + ((send name :is-equal-to-string #@"NSWindowDidExposeNotification") + :did-expose) + ((send name :is-equal-to-string #@"NSWindowDidResizeNotification") + :did-resize) + ((send name :is-equal-to-string #@"NSWindowWillCloseNotification") + :will-close) + (t :unknown)))) + +(defun event-type (event) +"Enumerates all the Cocoa events Beagle takes an interest in. Returns two +values; the first is the TYPE of event (mouse-up, mouse-move) and the +second is the button pressed at the time of the event. The latter value +will be NIL if no button was involved in the event (or if the event is +not a mouse event)." + (let ((event-type (send event 'type))) + (cond ((equal #$NSLeftMouseUp event-type) + (values :mouse-up :left)) + ((equal #$NSRightMouseUp event-type) + (values :mouse-up :right)) + ((equal #$NSOtherMouseUp event-type) + (values :mouse-up :other)) + ((equal #$NSLeftMouseDown event-type) + (values :mouse-down :left)) + ((equal #$NSRightMouseDown event-type) + (values :mouse-down :right)) + ((equal #$NSOtherMouseDown event-type) + (values :mouse-down :other)) + ((equal #$NSScrollWheel event-type) + (values :scroll-wheel nil)) + ((equal #$NSKeyDown event-type) + (values :key-down nil)) + ((equal #$NSKeyUp event-type) + (values :key-up nil)) + ((equal #$NSMouseMoved event-type) + (values :mouse-moved nil)) + ((equal #$NSLeftMouseDragged event-type) + (values :mouse-moved :left)) + ((equal #$NSRightMouseDragged event-type) + (values :mouse-moved :right)) + ((equal #$NSOtherMouseDragged event-type) + (values :mouse-moved :other)) + ((equal #$NSMouseEntered event-type) + ;; Not really a mouse event... + (values :mouse-enter nil)) + ((equal #$NSMouseExited event-type) + ;; Not really a mouse event... + (values :mouse-exit nil)) + ((equal #$NSFlagsChanged event-type) + (values :flags-changed nil)) + (t (values :unknown nil))))) + + +;;; Record current pointer position + button state so we can 'synthesize' a motion +;;; event at will... this feels like a hack. Is it really necessary? +(defun set-hacky-graft/view-xy (graft-xy view-xy) + (declare (special *-current-pointer-graft-xy-* + *-current-pointer-view-xy-*)) + + ;; Need to free memory assigned via 'make-record'. There's no nice way to do + ;; this :-( + + (unless (or (null *-current-pointer-graft-xy-*) + (eql (%null-ptr) *-current-pointer-graft-xy-*)) + (#_free *-current-pointer-graft-xy-*)) + + (unless (or (null *-current-pointer-view-xy-*) + (eql (%null-ptr) *-current-pointer-view-xy-*)) + (#_free *-current-pointer-view-xy-*)) + + (setf *-current-pointer-graft-xy-* (ccl::make-record :<NSP>oint + :x (pref graft-xy :<NSP>oint.x) + :y (pref graft-xy :<NSP>oint.y))) + (setf *-current-pointer-view-xy-* (ccl::make-record :<NSP>oint + :x (pref view-xy :<NSP>oint.x) + :y (pref view-xy :<NSP>oint.y)))) + + +(defun set-hacky-button-state (state) + (declare (special *-current-pointer-button-state*-)) + (setf *-current-pointer-button-state*- state)) + + (let ((timestamp 0)) (defun beagle-notification-to-clim-event (window notification &optional origin-x origin-y width height) (declare (special *beagle-port*)) (let ((return-event nil) - (sheet (%beagle-port-lookup-sheet-for-view *beagle-port* (send window 'content-view)))) + (sheet (%beagle-port-lookup-sheet-for-view *beagle-port* (send window 'content-view))) + (n-type (notification-type notification))) ;; We don't get exposure notifications when the window has a (Cocoa) backing store. + ;; Use 'ecase' for this, like in medium-draw-text? (cond - ((send (send notification 'name) :is-equal-to-string #@"NSWindowDidBecomeKeyNotification") + ((eq :became-key n-type) (setf return-event nil) (when (send window 'is-visible) ; only do if window is on-screen... (let* ((content-view (send window 'content-view)) @@ -313,7 +374,7 @@ (focus (climi::keyboard-input-focus frame))) (unless (null target-sheet) (setf (port-keyboard-input-focus *beagle-port*) focus))))) - ((send (send notification 'name) :is-equal-to-string #@"NSWindowDidExposeNotification") + ((eq :did-expose n-type) (setf return-event (make-instance 'window-repaint-event :timestamp (incf timestamp) :sheet sheet @@ -321,273 +382,255 @@ ;; seem to be a way to specify a region... coord ;; system? :region (make-rectangle* origin-x origin-y width height)))) - ((send (send notification 'name) :is-equal-to-string #@"NSWindowDidResizeNotification") + ((eq :did-resize n-type) (setf return-event (make-instance 'window-configuration-event :sheet sheet :x origin-x ; coord system? :y origin-y :width width :height height))) - ((send (send notification 'name) :is-equal-to-string #@"NSWindowWillCloseNotification") + ((eq :will-close n-type) (setf return-event (make-instance 'window-destroy-event :sheet sheet))) - ;; TODO: this logic is the same as the previous version, but - ;; is it correct? it means that if we get a - ;; notification that we don't recognize, we ignore it + ;; Ignore notifications in which we're uninterested. (t nil)) return-event))

(defun beagle-event-to-clim-event (mirror event) - (declare (special *-current-pointer-button-state-* - *-current-pointer-view-xy-* - *-current-pointer-graft-xy-*)) + (declare (special *-current-pointer-button-state-*)) + (let ((window (send event 'window)) - (return-event event) - ;; Can't do this here any more - it breaks NSFlagsChanged event handling :-( -;;; (modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags))) - (event-type (send event 'type))) - (when (or (equal #$NSLeftMouseUp event-type) - (equal #$NSLeftMouseDown event-type) - (equal #$NSRightMouseUp event-type) - (equal #$NSRightMouseDown event-type) - (equal #$NSOtherMouseUp event-type) - (equal #$NSOtherMouseDown event-type)) - (slet ((location-in-window-point (send event 'location-in-window)) - (window-bounds (send (send window 'content-view) 'bounds))) - (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) - (pref location-in-window-point :<NSP>oint.y))) - - ;;; *SUSPECT* this will leak; gc won't collect heap-allocated store from make-record will it? - (slet ((location-in-view-point (send mirror :convert-point location-in-window-point - :from-view (send window 'content-view))) - (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) - - (setf *-current-pointer-graft-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-screen-point :<NSP>oint.x) - :y (pref location-in-screen-point :<NSP>oint.y))) - (setf *-current-pointer-view-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y))) - (setf return-event - (make-instance (if (or (equal #$NSLeftMouseUp event-type) - (equal #$NSRightMouseUp event-type) - (equal #$NSOtherMouseUp event-type)) - 'pointer-button-release-event - 'pointer-button-press-event) - :pointer 0 - :button (cond ((or (equal event-type #$NSLeftMouseUp) - (equal event-type #$NSLeftMouseDown)) - (setf *-current-pointer-button-state-* +pointer-left-button+) - +pointer-left-button+) - ((or (equal event-type #$NSRightMouseUp) - (equal event-type #$NSRightMouseDown)) - (setf *-current-pointer-button-state-* +pointer-right-button+) - +pointer-right-button+) - (t - (setf *-current-pointer-button-state-* +pointer-middle-button+) - +pointer-middle-button+)) - ;; x and y are in window coordinates. They need converting to screen - ;; coordinates. Can do this with - ;; [window convertBaseToScreen:location-in-window].x or .y. - ;; They probably need coercing too :-( - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y) - :graft-x (pref location-in-screen-point :<NSP>oint.x) - :graft-y (pref location-in-screen-point :<NSP>oint.y) - :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - ;; Timestamp from Cocoa looks like 12345.7 - CLIM wants integer no - ;; bigger than a fixnum, so it gets a fixnum. Hope Cocoa doesn't - ;; send non-unique timestamps. - ;; NSTimeInterval is a double typedef - :timestamp (incf timestamp)))))) - ;; (coerce (* 10 (pref timestamp :<NST>ime<I>nterval)) 'fixnum)))))) - - (when (equal #$NSScrollWheel event-type) - (setf return-event (make-instance 'pointer-button-press-event - :pointer 0 - ;; The 'amount' of scroll can be specified in Cocoa by a - ;; larger or smaller delta in either X, Y or Z directions. - ;; We ignore this, and always pass up or down and let - ;; CLIM set the amount. Could do better with scroll wheel - ;; events, CLIM also ignores X and Z deltas... - :button (if (plusp (send event 'delta-y)) + (return-event event)) + (multiple-value-bind (event-type button) + (event-type event) + (when (or (eq :mouse-up event-type) + (eq :mouse-down event-type)) + (slet ((location-in-window-point (send event 'location-in-window)) + (window-bounds (send (send window 'content-view) 'bounds))) + (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) + (pref location-in-window-point :<NSP>oint.y))) + + (slet ((location-in-view-point (send mirror :convert-point location-in-window-point + :from-view (send window 'content-view))) + (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) + + ;; Only want this for 'synthesize-point-motion-event' + (set-hacky-graft/view-xy location-in-screen-point + location-in-view-point) + + (setf return-event + (make-instance (if (eq :mouse-up event-type) + 'pointer-button-release-event + 'pointer-button-press-event) + :pointer 0 + :button (cond ((eq :left button) + (set-hacky-button-state +pointer-left-button+) + +pointer-left-button+) + ((eq :right button) + (set-hacky-button-state +pointer-right-button+) + +pointer-right-button+) + (t + (set-hacky-button-state +pointer-middle-button+) + +pointer-middle-button+)) + ;; x and y are in window coordinates. They need converting to screen + ;; coordinates. Can do this with + ;; [window convertBaseToScreen:location-in-window].x or .y. + ;; They probably need coercing too :-( + :x (pref location-in-view-point :<NSP>oint.x) + :y (pref location-in-view-point :<NSP>oint.y) + :graft-x (pref location-in-screen-point :<NSP>oint.x) + :graft-y (pref location-in-screen-point :<NSP>oint.y) + :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + ;; Timestamp from Cocoa looks like 12345.7 - CLIM wants integer no + ;; bigger than a fixnum, so it gets a fixnum. Hope Cocoa doesn't + ;; send non-unique timestamps. + ;; NSTimeInterval is a double typedef + :timestamp (incf timestamp)))))) + + (when (eq :scroll-wheel event-type) + (setf return-event (make-instance 'pointer-button-press-event + :pointer 0 + ;; The 'amount' of scroll can be specified in Cocoa by a + ;; larger or smaller delta in either X, Y or Z directions. + ;; We ignore this, and always pass up or down and let + ;; CLIM set the amount. Could do better with scroll wheel + ;; events, CLIM also ignores X and Z deltas... + :button (if (plusp (send event 'delta-y)) + (progn + (set-hacky-button-state +pointer-wheel-up+) + +pointer-wheel-up+) (progn - (setf *-current-pointer-button-state-* +pointer-wheel-up+) - +pointer-wheel-up+) - (progn - (setf *-current-pointer-button-state-* +pointer-wheel-down+) - +pointer-wheel-down+)) - ;; Surely scroll-wheel events do not need x, y coords? input.lisp - ;; does a 'call-next-method' after handling the scroll but won't - ;; that then get passed as a 'proper' button press? Best pass these - ;; as values we're unlikely to ever get clicked. - :x 0 - :y 0 - :graft-x 0 - :graft-y 0 - :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - ;; Timestamp from Cocoa looks like 12345.7 - CLIM wants integer no - ;; bigger than a fixnum, so it gets a fixnum. Hope Cocoa doesn't - ;; send non-unique timestamps. - ;; NSTimeInterval is a double typedef - :timestamp (incf timestamp)))) + (set-hacky-button-state +pointer-wheel-down+) + +pointer-wheel-down+)) + ;; Surely scroll-wheel events do not need x, y coords? input.lisp + ;; does a 'call-next-method' after handling the scroll but won't + ;; that then get passed as a 'proper' button press? Best pass these + ;; as values we're unlikely to ever get clicked. + :x 0 + :y 0 + :graft-x 0 + :graft-y 0 + :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + ;; Timestamp from Cocoa looks like 12345.7 - CLIM wants integer at least + ;; as big as a fixnum, so it gets a fixnum. Hope Cocoa doesn't + ;; send non-unique timestamps. + ;; NSTimeInterval is a double typedef + :timestamp (incf timestamp))))

- ;; Keyname should probably be the #$NSF1FunctionKey, #$NSUpArrowFunctionKey etc as defined in the docs - ;; for NSEvent (these are permitted to be implementation defined - not sure if that's the back end - ;; implementation or the McCLIM implementation!), apart from the "standard" keys which should be symbols - ;; in the keyword package (presumably :a :b :c etc.?) + ;; Keyname should probably be the #$NSF1FunctionKey, #$NSUpArrowFunctionKey etc as defined in the docs + ;; for NSEvent (these are permitted to be implementation defined - not sure if that's the back end + ;; implementation or the McCLIM implementation!), apart from the "standard" keys which should be symbols + ;; in the keyword package (presumably :a :b :c etc.?)

- ;; ::FIXME:: WILL ONLY WORK FOR "STANDARD" KEYS!!! + ;; ::FIXME:: WILL ONLY WORK FOR "STANDARD" KEYS!!!

- (when (or (equal #$NSKeyDown event-type) - (equal #$NSKeyUp event-type)) - (let ((keyname (beagle-key-event-to-key-name event))) -;;; (format *terminal-io* "In event-build with keyname: ~A (characterp = ~A)~%" keyname (characterp keyname)) - (setf return-event (make-instance (if (equal #$NSKeyDown event-type) - 'key-press-event - 'key-release-event) - :key-name keyname - ;; not needed by spec - should change implementation? - :key-character (and (characterp keyname) keyname) - :x 0 ; Not needed for key events? - :y 0 ; Not needed for key events? - :graft-x 0 ; Not needed for key events? - :graft-y 0 ; Not needed for key events? - ;; Irrespective of where the key event happened, send it - ;; to the sheet that has key-focus for the port. - :sheet (beagle-port-key-focus *beagle-port*) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - :timestamp (incf timestamp))))) - (when (or (equal #$NSMouseMoved event-type) - (equal #$NSLeftMouseDragged event-type) - (equal #$NSRightMouseDragged event-type) - (equal #$NSOtherMouseDragged event-type)) - (slet ((location-in-window-point (send event 'location-in-window)) - (window-bounds (send (send window 'content-view) 'bounds))) - ;; Because the location in window is *not* flipped, we need to flip it... (note: we flip by the size - ;; of the window's content view, otherwise we end up out by the size of the window title bar). - ;; *SUSPECT* this will leak; gc won't collect heap-allocated store from make-record will it? - (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) - (pref location-in-window-point :<NSP>oint.y))) - (slet ((location-in-view-point (send mirror :convert-point location-in-window-point - :from-view (send window 'content-view))) - (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) - - (setf *-current-pointer-graft-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-screen-point :<NSP>oint.x) - :y (pref location-in-screen-point :<NSP>oint.y))) - (setf *-current-pointer-view-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y))) - (setf return-event - (make-instance 'pointer-motion-event - :pointer 0 - :button (cond ((equal event-type #$NSMouseMoved) - (setf *-current-pointer-button-state-* 0) - 0) - ((equal event-type #$NSLeftMouseDragged) - (setf *-current-pointer-button-state-* +pointer-left-button+) - +pointer-left-button+) - ((equal event-type #$NSRightMouseDragged) - (setf *-current-pointer-button-state-* +pointer-right-button+) - +pointer-right-button+) - (t - (setf *-current-pointer-button-state-* +pointer-middle-button+) - +pointer-middle-button+)) - ;; It looks like McCLIM diverges from the spec again in relation - ;; to events (I wonder who is responsible? 8-) and expects :x and - ;; :y to be relative to the MIRROR in which the events occur. - ;; :x (pref location-in-screen-point :<NSP>oint.x) - ;; :y (pref location-in-screen-point :<NSP>oint.y) - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y) - ;; Even though graft-x, graft-y is *not in the spec* we need to populate - ;; them because there's code in McCLIM/gadgets.lisp that makes direct - ;; use of the graft-x/y slot values. Naughty. So how does this differ - ;; from :x and :y which are supposedly in native coordinates? Methinks - ;; that the event hierarchy and associated code in McCLIM should perhaps - ;; be revisited... currently it appears that these are *only* used to support - ;; pointer-motion-events. Strange. It doesn't seem to make any difference what - ;; gets set here! Suspect we're not invoking the callback because we're not - ;; passing the correct sheet...? + (when (or (eq :key-down event-type) + (eq :key-up event-type)) + (let ((keyname (beagle-key-event-to-key-name event))) + (setf return-event (make-instance (if (eq :key-down event-type) + 'key-press-event + 'key-release-event) + :key-name keyname + ;; not needed by spec - should change implementation? + :key-character (and (characterp keyname) keyname) + :x 0 ; Not needed for key events? + :y 0 ; Not needed for key events? + :graft-x 0 ; Not needed for key events? + :graft-y 0 ; Not needed for key events? + ;; Irrespective of where the key event happened, send it + ;; to the sheet that has key-focus for the port. + :sheet (beagle-port-key-focus *beagle-port*) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + :timestamp (incf timestamp))))) + + (when (eq :mouse-moved event-type) + (slet ((location-in-window-point (send event 'location-in-window)) + (window-bounds (send (send window 'content-view) 'bounds))) + ;; Because the location in window is *not* flipped, we need to flip it... (note: we flip by the size + ;; of the window's content view, otherwise we end up out by the size of the window title bar). + (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) + (pref location-in-window-point :<NSP>oint.y))) + (slet ((location-in-view-point (send mirror :convert-point location-in-window-point + :from-view (send window 'content-view))) + (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) + + (set-hacky-graft/view-xy location-in-screen-point + location-in-view-point) + + (setf return-event + (make-instance 'pointer-motion-event + :pointer 0 + :button (cond ((null button) + (set-hacky-button-state 0) + 0) + ((eq :left button) + (set-hacky-button-state +pointer-left-button+) + +pointer-left-button+) + ((eq :right button) + (set-hacky-button-state +pointer-right-button+) + +pointer-right-button+) + (t + (set-hacky-button-state +pointer-middle-button+) + +pointer-middle-button+)) + ;; It looks like McCLIM diverges from the spec again in relation + ;; to events (I wonder who is responsible? 8-) and expects :x and + ;; :y to be relative to the MIRROR in which the events occur. + ;; :x (pref location-in-screen-point :<NSP>oint.x) + ;; :y (pref location-in-screen-point :<NSP>oint.y) + :x (pref location-in-view-point :<NSP>oint.x) + :y (pref location-in-view-point :<NSP>oint.y) + ;; Even though graft-x, graft-y is *not in the spec* we need to populate + ;; them because there's code in McCLIM/gadgets.lisp that makes direct + ;; use of the graft-x/y slot values. Naughty. So how does this differ + ;; from :x and :y which are supposedly in native coordinates? Methinks + ;; that the event hierarchy and associated code in McCLIM should perhaps + ;; be revisited... currently it appears that these are *only* used to support + ;; pointer-motion-events. Strange. It doesn't seem to make any difference what + ;; gets set here! Suspect we're not invoking the callback because we're not + ;; passing the correct sheet...? ;;; :graft-x (pref location-in-view-point :<NSP>oint.x) ;0 ;;; :graft-y (pref location-in-view-point :<NSP>oint.y) ;0 - :graft-x (pref location-in-screen-point :<NSP>oint.x) ;0 - :graft-y (pref location-in-screen-point :<NSP>oint.y) ;0 - ;; This is probably wrong too; the NSWindow receives and propogates mouse - ;; moved events, but we need to translate them into an appropriate view. - ;; Not sure quite how we do that, but I think we need to... we're ok for - ;; key down / up, we keep track of the "key view". Do we also need to keep - ;; track of what interactors we have? I suspect not. We just need to traverse - ;; the NSView hierarchy (or sheet hierarchy, whichever is easiest) until we - ;; find the "youngest" view (or sheet) over which the event occurred; this - ;; is the sheet that should handle the event. - :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) + :graft-x (pref location-in-screen-point :<NSP>oint.x) ;0 + :graft-y (pref location-in-screen-point :<NSP>oint.y) ;0 + ;; This is probably wrong too; the NSWindow receives and propogates mouse + ;; moved events, but we need to translate them into an appropriate view. + ;; Not sure quite how we do that, but I think we need to... we're ok for + ;; key down / up, we keep track of the "key view". Do we also need to keep + ;; track of what interactors we have? I suspect not. We just need to traverse + ;; the NSView hierarchy (or sheet hierarchy, whichever is easiest) until we + ;; find the "youngest" view (or sheet) over which the event occurred; this + ;; is the sheet that should handle the event. + :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + :timestamp (incf timestamp)))))) + + (when (or (eq :mouse-enter event-type) + (eq :mouse-exit event-type)) + #+nil + (let ((view-sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror))) + (when (typep view-sheet 'clim:push-button-pane) + (format *debug-io* "Got ~a event on sheet ~a~%" + event-type view-sheet))) + (slet ((location-in-window-point (send event 'location-in-window)) + (window-bounds (send (send window 'content-view) 'bounds))) + ;; Because the location in window is *not* flipped, we need to flip it... + ;; (note: we flip by the size of the window's content view, otherwise we + ;; end up out by the size of the window title bar). + + ;; Is this where things are going wrong with PUSH-BUTTON-PANE buttons? + ;; Could be... whatever, I think this is a little dodgy... + (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) + (pref location-in-window-point :<NSP>oint.y))) + (slet ((location-in-view-point (send mirror :convert-point location-in-window-point + :from-view (send window 'content-view))) + (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) + + (set-hacky-graft/view-xy location-in-screen-point + location-in-view-point) + + ;; This event does not provide button state, but we can use *-current-pointer-button-state-* + ;; to populate button state in the CLIM event. Obviously, we do not need to update this value + ;; (*-current-pointer-button-state-*) for enter / exit events... + (setf return-event + (make-instance (if (eq :mouse-enter event-type) + 'pointer-enter-event + 'pointer-exit-event) + :pointer 0 + :button *-current-pointer-button-state-* + :x (pref location-in-view-point :<NSP>oint.x) + :y (pref location-in-view-point :<NSP>oint.y) + :graft-x (pref location-in-screen-point :<NSP>oint.x) ;0 + :graft-y (pref location-in-screen-point :<NSP>oint.y) ;0 + :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) + :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) + :timestamp (incf timestamp)))))) + + ;; We need to maintain the modifier flags state constantly to be able to + ;; implement this; suggest a slot in beagle-port? + (when (eq :flags-changed event-type) + ;; Use the 'old' 'modifiers' in conjunction with the new 'modifier-state' + ;; to work out if this is a key up or a key down... + (setf return-event + (destructuring-bind (event-class key) + (current-mods-map-to-key (send event 'modifier-flags)) + (make-instance event-class + :key-name key + :key-character nil + :x 0 + :y 0 + :graft-x 0 + :graft-y 0 + ;; Irrespective of where the key event happened, send it + ;; to the sheet that has key-focus for the port. + :sheet (beagle-port-key-focus *beagle-port*) :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - :timestamp (incf timestamp)))))) - (when (or (equal #$NSMouseEntered event-type) - (equal #$NSMouseExited event-type)) -;;; (format *debug-io* "Got mouse entered / exited event for mirror ~S~%" mirror) - (slet ((location-in-window-point (send event 'location-in-window)) - (window-bounds (send (send window 'content-view) 'bounds))) - ;; Because the location in window is *not* flipped, we need to flip it... (note: we flip by the size - ;; of the window's content view, otherwise we end up out by the size of the window title bar). - (setf (pref location-in-window-point :<NSP>oint.y) (- (pref window-bounds :<NSR>ect.size.height) - (pref location-in-window-point :<NSP>oint.y))) - (slet ((location-in-view-point (send mirror :convert-point location-in-window-point - :from-view (send window 'content-view))) - (location-in-screen-point (send window :convert-base-to-screen location-in-window-point))) - - (setf *-current-pointer-graft-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-screen-point :<NSP>oint.x) - :y (pref location-in-screen-point :<NSP>oint.y))) - (setf *-current-pointer-view-xy-* (ccl::make-record :<NSP>oint - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y))) - ;; This event does not provide button state, but we can use *-current-pointer-button-state-* - ;; to populate button state in the CLIM event. Obviously, we do not need to update this value - ;; (*-current-pointer-button-state-*) for enter / exit events... - (setf return-event - (make-instance (if (equal #$NSMouseEntered event-type) - 'pointer-enter-event - 'pointer-exit-event) - :pointer 0 - :button *-current-pointer-button-state-* - :x (pref location-in-view-point :<NSP>oint.x) - :y (pref location-in-view-point :<NSP>oint.y) - :graft-x (pref location-in-screen-point :<NSP>oint.x) ;0 - :graft-y (pref location-in-screen-point :<NSP>oint.y) ;0 - :sheet (%beagle-port-lookup-sheet-for-view *beagle-port* mirror) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - :timestamp (incf timestamp)))))) - - ;; We need to maintain the modifier flags state constantly to be able to - ;; implement this; suggest a slot in beagle-port? - (when (equal #$NSFlagsChanged event-type) -;;; (format *debug-io* "In event-build (flags changed)~%") - ;; Use the 'old' 'modifiers' in conjunction with the new 'modifier-state' - ;; to work out if this is a key up or a key down... - (setf return-event - (destructuring-bind (event-class key) - (current-mods-map-to-key (send event 'modifier-flags)) - (make-instance event-class - :key-name key - :key-character nil - :x 0 - :y 0 - :graft-x 0 - :graft-y 0 - ;; Irrespective of where the key event happened, send it - ;; to the sheet that has key-focus for the port. - :sheet (beagle-port-key-focus *beagle-port*) - :modifier-state (beagle-modifier-to-modifier-state (send event 'modifier-flags)) - :timestamp (incf timestamp))))) + :timestamp (incf timestamp)))))

- ;; #$NSHelpRequested- wonder if we can convert this into "user pressed help key" key event? - ;; Then could pull up docs (or could do if there were any!) - ;; #$NSCursorUpdate + ;; #$NSHelpRequested- wonder if we can convert this into "user pressed help key" key event? + ;; Then could pull up docs (or could do if there were any!) + ;; #$NSCursorUpdate

- return-event)) + return-event)))

;;; This has been added to McCLIM and the CLX back end; I'm not sure what it's supposed ;;; to be for. Never mind, add it anyway. defgeneric is in stream-input.lisp