[mcclim-cvs] CVS mcclim/Backends/Graphic-Forms
dlichteblau
dlichteblau at common-lisp.net
Sun Mar 18 14:29:00 UTC 2007
Update of /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms
In directory clnet:/tmp/cvs-serv5295
Modified Files:
port.lisp
Log Message:
No idea why graphic-forms works this way, but get-next-event consistently
processed more than one event, all of which were discarded except for the
last one. Push the events into a list instead and return them in order.
This fixes disappearing pane contents, since most repaint events were
lost.
* Backends/Graphic-Forms/port.lisp (GRAPHIC-FORMS-PORT): New slot
EVENTS, renamed from EVENT. (ENQUEUE): New function.
(GET-NEXT-EVENT): Rewritten to pop from EVENTS. (EVENT-CLOSE,
EVENT-PAINT, EVENT-MOVE, EVENT-RESIZE, EVENT-SELECT,
EVENT-MOUSE-MOVE, EVENT-MOUSE-UP, EVENT-MOUSE-DOWN,
EVENT-KEY-DOWN, EVENT-KEY-UP): Use enqueue.
--- /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/16 14:42:49 1.4
+++ /project/mcclim/cvsroot/mcclim/Backends/Graphic-Forms/port.lisp 2007/03/18 14:29:00 1.5
@@ -103,13 +103,16 @@
(defclass graphic-forms-port (basic-port)
((id)
- (event
- :accessor event
+ (events
+ :accessor events
:initform nil)
(pointer
:accessor port-pointer
:initform (make-instance 'gfw-pointer))))
+(defun enqueue (port event)
+ (push event (events port)))
+
(defvar *sheet-dispatcher* (make-instance 'sheet-event-dispatcher))
(defvar *pane-dispatcher* (make-instance 'pane-event-dispatcher))
@@ -263,20 +266,17 @@
(defmethod get-next-event ((port graphic-forms-port) &key wait-function (timeout nil))
(declare (ignore wait-function timeout)) ; FIXME
- (setf (event port) nil)
- (cffi:with-foreign-object (msg-ptr 'gfs::msg)
- (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0))
- (event nil))
- (cffi:with-foreign-slots ((gfs::hwnd gfs::message gfs::wparam gfs::lparam
- gfs::time gfs::pnt)
- msg-ptr gfs::msg)
- (unless (gfw::default-message-filter gm msg-ptr)
- (if (setf event (event port))
- (setf (slot-value event 'climi::timestamp) gfs::time)
- #+nil (gfs::debug-format "unhandled Win32 message ID: #x~x~%"
- (gfs::lparam-low-word gfs::message))))
- (setf (event port) nil))
- event)))
+ (or (pop (events port))
+ (cffi:with-foreign-object (msg-ptr 'gfs::msg)
+ (let ((gm (gfs::get-message msg-ptr (cffi:null-pointer) 0 0)))
+ (cffi:with-foreign-slots ((gfs::hwnd gfs::message gfs::wparam gfs::lparam
+ gfs::time gfs::pnt)
+ msg-ptr gfs::msg)
+ (unless (gfw::default-message-filter gm msg-ptr)
+ (dolist (event (events port))
+ (setf (slot-value event 'climi::timestamp) gfs::time)))))
+ (setf (events port) (nreverse (events port)))
+ (pop (events port)))))
(defmethod process-next-event :after ((port graphic-forms-port) &key wait-function (timeout nil))
(declare (ignore wait-function timeout))
@@ -406,8 +406,8 @@
(gfs::debug-format "menu item: ~a invoked~%" item))
(defmethod gfw:event-close ((self sheet-event-dispatcher) mirror)
- (setf (event (port self)) (make-instance 'window-manager-delete-event
- :sheet (sheet mirror))))
+ (enqueue (port self)
+ (make-instance 'window-manager-delete-event :sheet (sheet mirror))))
;; copy&paste from port.lisp|CLX:
(defun sheet-desired-ink (sheet)
@@ -434,10 +434,10 @@
(setf (gfg:background-color gc) c
(gfg:foreground-color gc) c))
(gfg:draw-filled-rectangle gc rect)))
- (setf (event (port self))
- (make-instance 'window-repaint-event
- :sheet sheet
- :region (translate-rectangle rect)))))
+ (enqueue (port self)
+ (make-instance 'window-repaint-event
+ :sheet sheet
+ :region (translate-rectangle rect)))))
(defun generate-configuration-event (mirror pnt size)
(make-instance 'window-configuration-event
@@ -448,7 +448,8 @@
:height (gfs:size-height size)))
(defmethod gfw:event-move ((self sheet-event-dispatcher) mirror pnt)
- (setf (event (port self)) (generate-configuration-event mirror pnt (gfw:client-size mirror))))
+ (enqueue (port self)
+ (generate-configuration-event mirror pnt (gfw:client-size mirror))))
(defmethod gfw:event-resize ((self sheet-event-dispatcher) mirror size type)
(declare (ignore type))
@@ -457,21 +458,21 @@
(let ((medium (climi::sheet-medium sheet)))
(if (and medium (image-of medium))
(resize-medium-buffer medium size))))
- (setf (event (port self))
- (generate-configuration-event mirror (gfw:location mirror) size))))
+ (enqueue (port self)
+ (generate-configuration-event mirror (gfw:location mirror) size))))
(defclass gadget-event (window-event) ())
(defclass button-pressed-event (gadget-event) ())
(defmethod gfw:event-select ((self pane-event-dispatcher) mirror)
- (setf (event (port self))
- (typecase mirror
- (gfw-button
- (make-instance 'button-pressed-event :sheet (sheet mirror)))
- (t
- (make-instance 'menu-clicked-event
- :sheet (sheet (gfw:owner mirror))
- :item (sheet mirror))))))
+ (enqueue (port self)
+ (typecase mirror
+ (gfw-button
+ (make-instance 'button-pressed-event :sheet (sheet mirror)))
+ (t
+ (make-instance 'menu-clicked-event
+ :sheet (sheet (gfw:owner mirror))
+ :item (sheet mirror))))))
(defmethod handle-event ((pane push-button) (event button-pressed-event))
(activate-callback pane (gadget-client pane) (gadget-id pane)))
@@ -487,49 +488,46 @@
(defmethod gfw:event-mouse-move
((self sheet-event-dispatcher) mirror point button)
- (setf (event (port self))
- (make-instance 'pointer-motion-event
- :pointer 0
- :sheet (sheet mirror)
- :x (gfs:point-x point)
- :y (gfs:point-y point)
- :button (translate-button-name button)
- ;; FIXME:
-;;; :timestamp
+ (enqueue (port self)
+ (make-instance 'pointer-motion-event
+ :pointer 0
+ :sheet (sheet mirror)
+ :x (gfs:point-x point)
+ :y (gfs:point-y point)
+ :button (translate-button-name button)
+ ;; FIXME:
;;; :graft-x
;;; :graft-y
- :modifier-state 0
- )))
+ :modifier-state 0
+ )))
(defmethod gfw:event-mouse-down ((self sheet-event-dispatcher) mirror point button)
- (setf (event (port self))
- (make-instance 'pointer-button-press-event
- :pointer 0
- :sheet (sheet mirror)
- :x (gfs:point-x point)
- :y (gfs:point-y point)
- :button (translate-button-name button)
- ;; FIXME:
-;;; :timestamp
+ (enqueue (port self)
+ (make-instance 'pointer-button-press-event
+ :pointer 0
+ :sheet (sheet mirror)
+ :x (gfs:point-x point)
+ :y (gfs:point-y point)
+ :button (translate-button-name button)
+ ;; FIXME:
;;; :graft-x
;;; :graft-y
- :modifier-state 0
- )))
+ :modifier-state 0
+ )))
(defmethod gfw:event-mouse-up ((self sheet-event-dispatcher) mirror point button)
- (setf (event (port self))
- (make-instance 'pointer-button-release-event
- :pointer 0
- :sheet (sheet mirror)
- :x (gfs:point-x point)
- :y (gfs:point-y point)
- :button (translate-button-name button)
- ;; FIXME:
-;;; :timestamp
+ (enqueue (port self)
+ (make-instance 'pointer-button-release-event
+ :pointer 0
+ :sheet (sheet mirror)
+ :x (gfs:point-x point)
+ :y (gfs:point-y point)
+ :button (translate-button-name button)
+ ;; FIXME:
;;; :graft-x
;;; :graft-y
- :modifier-state 0
- )))
+ :modifier-state 0
+ )))
(defun char-to-sym (char)
(case char
@@ -549,34 +547,32 @@
(#\Tab :TAB) (#\Return :RETURN) (#\Rubout :DELETE)))
(defmethod gfw:event-key-down ((self sheet-event-dispatcher) mirror code char)
- (setf (event (port self))
- (make-instance 'key-press-event
- :key-name (char-to-sym char)
- :key-character char
- :sheet (sheet mirror)
- ;; FIXME:
- :x 0
- :y 0
- :modifier-state 0
-;;; :timestamp time
+ (enqueue (port self)
+ (make-instance 'key-press-event
+ :key-name (char-to-sym char)
+ :key-character char
+ :sheet (sheet mirror)
+ ;; FIXME:
+ :x 0
+ :y 0
+ :modifier-state 0
;;; :graft-x root-x
;;; :graft-y root-y
- )))
+ )))
(defmethod gfw:event-key-up ((self sheet-event-dispatcher) mirror code char)
- (setf (event (port self))
- (make-instance 'key-release-event
- :key-name (char-to-sym char)
- :key-character char
- :sheet (sheet mirror)
- ;; FIXME:
- :x 0
- :y 0
- :modifier-state 0
-;;; :timestamp time
+ (enqueue (port self)
+ (make-instance 'key-release-event
+ :key-name (char-to-sym char)
+ :key-character char
+ :sheet (sheet mirror)
+ ;; FIXME:
+ :x 0
+ :y 0
+ :modifier-state 0
;;; :graft-x root-x
;;; :graft-y root-y
- )))
+ )))
;;;
More information about the Mcclim-cvs
mailing list