/[mcclim]/mcclim/input.lisp
ViewVC logotype

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Fri Aug 2 11:59:09 2002 UTC (11 years, 8 months ago) by adejneka
Branch: MAIN
Changes since 1.17: +0 -64 lines
* Moved TRACKING-POINTER to a separate file.

* Added tracking of presentations.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2002 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
21 (in-package :CLIM-INTERNALS)
22
23 ;;; Input Protocol Classes
24
25 ;; Event queues
26
27 (defclass standard-event-queue ()
28 ((lock :initform (make-lock "event queue")
29 :reader event-queue-lock)
30 (head :initform nil
31 :accessor event-queue-head
32 :documentation "Head pointer of event queue.")
33 (tail :initform nil
34 :accessor event-queue-tail
35 :documentation "Tail pointer of event queue.") ))
36
37 (defmethod event-queue-read-no-hang ((eq standard-event-queue))
38 "Reads one event from the queue, if there is no event just return NIL."
39 (with-lock-held ((event-queue-lock eq))
40 (let ((res (pop (event-queue-head eq))))
41 (when (null (event-queue-head eq))
42 (setf (event-queue-tail eq) nil))
43 res)))
44
45 (defmethod event-queue-read ((eq standard-event-queue))
46 "Reads one event from the queue, if there is no event, hang until here is one."
47 (loop
48 (let ((res (event-queue-read-no-hang eq)))
49 (when res
50 (return res))
51 (if *multiprocessing-p*
52 (process-wait "Waiting for event"
53 (lambda ()
54 (not (null (event-queue-head eq)))))
55 (process-wait "Waiting for event"
56 (lambda ()
57 (loop for port in climi::*all-ports*
58 ; this is dubious
59 do (process-next-event port))
60 (not (null (event-queue-head eq)))))))))
61
62 (defmethod event-queue-read-with-timeout ((eq standard-event-queue)
63 timeout wait-function)
64 (loop
65 (let ((res (event-queue-read-no-hang eq)))
66 (when res
67 (return res))
68 (if *multiprocessing-p*
69 (process-wait-with-timeout "Waiting for event"
70 timeout
71 (lambda ()
72 (or
73 (not (null (event-queue-head eq)))
74 (funcall wait-function))))
75 (process-wait-with-timeout "Waiting for event"
76 timeout
77 (lambda ()
78 (loop for port in climi::*all-ports*
79 ;; this is dubious
80 do (process-next-event port))
81 (or
82 (not (null (event-queue-head eq)))
83 (funcall wait-function))))))))
84
85 (defmethod event-queue-append ((eq standard-event-queue) item)
86 "Append the item at the end of the queue. Does event compression."
87 (with-lock-held ((event-queue-lock eq))
88 (cond
89 ;; Motion Event Compression
90 ;;
91 ;; . find the (at most one) motion event
92 ;; . delete it
93 ;; . append item to queue
94 ;;
95 ;; But leave enter/exit events.
96 ;;
97 ((and (typep item 'pointer-motion-event)
98 (not (typep item 'pointer-boundary-event)))
99 (let ((sheet (event-sheet item)))
100 (labels ((fun (xs)
101 (cond ((null xs)
102 (setf (event-queue-tail eq) (cons item nil)) )
103 ((and (typep (car xs) 'pointer-motion-event)
104 (not (typep (car xs) 'pointer-boundary-event))
105 (eq (event-sheet (car xs)) sheet))
106 ;; delete this
107 (fun (cdr xs)))
108 (t
109 (setf (cdr xs) (fun (cdr xs)))
110 xs))))
111 (setf (event-queue-head eq) (fun (event-queue-head eq))))))
112 ;;
113 ;; Repaint event compression
114 ;;
115 ((typep item 'window-repaint-event)
116 (let ((region (window-event-native-region item))
117 (sheet (event-sheet item))
118 (did-something-p nil))
119 (labels ((fun (xs)
120 (cond ((null xs)
121 ;; We reached the queue's tail: Append the new event, construct a new
122 ;; one if necessary.
123 (when did-something-p
124 (setf item
125 (make-instance 'window-repaint-event
126 :timestamp (event-timestamp item)
127 :sheet (event-sheet item)
128 :region region)))
129 (setf (event-queue-tail eq) (cons item nil)) )
130 ;;
131 ((and (typep (car xs) 'window-repaint-event)
132 (eq (event-sheet (car xs)) sheet))
133 ;; This is a repaint event for the same sheet, delete it and combine
134 ;; its region into the new event.
135 (setf region
136 (region-union region (window-event-native-region (car xs))))
137 ;; Here is an alternative, which just takes the bounding rectangle.
138 ;; NOTE: When doing this also take care that the new region really
139 ;; is cleared.
140 ;; (setf region
141 ;; (let ((old-region (window-event-native-region (car xs))))
142 ;; (make-rectangle*
143 ;; (min (bounding-rectangle-min-x region)
144 ;; (bounding-rectangle-min-x old-region))
145 ;; (min (bounding-rectangle-min-y region)
146 ;; (bounding-rectangle-min-y old-region))
147 ;; (max (bounding-rectangle-max-x region)
148 ;; (bounding-rectangle-max-x old-region))
149 ;; (max (bounding-rectangle-max-y region)
150 ;; (bounding-rectangle-max-y old-region)))))
151 (setf did-something-p t)
152 (fun (cdr xs)))
153 ;;
154 (t
155 (setf (cdr xs) (fun (cdr xs)))
156 xs))))
157 (setf (event-queue-head eq) (fun (event-queue-head eq))))))
158 ;; Regular events are just appended:
159 (t
160 (cond ((null (event-queue-tail eq))
161 (setf (event-queue-head eq) (cons item nil)
162 (event-queue-tail eq) (event-queue-head eq)))
163 (t
164 (setf (event-queue-tail eq)
165 (setf (cdr (event-queue-tail eq)) (cons item nil)))))))))
166
167 (defmethod event-queue-prepend ((eq standard-event-queue) item)
168 "Prepend the item to the beginning of the queue."
169 (with-lock-held ((event-queue-lock eq))
170 (cond ((null (event-queue-tail eq))
171 (setf (event-queue-head eq) (cons item nil)
172 (event-queue-tail eq) (event-queue-head eq)))
173 (t
174 (push item (event-queue-head eq))))))
175
176 (defmethod event-queue-peek ((eq standard-event-queue))
177 (with-lock-held ((event-queue-lock eq))
178 (first (event-queue-head eq))))
179
180 (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
181 "Goes thru the whole event queue and returns the first event, which
182 satisfies 'predicate' and leaves the event in the queue.
183 Returns NIL, if there is no such event."
184 (with-lock-held ((event-queue-lock eq))
185 (find-if predicate (event-queue-head eq))))
186
187 (defmethod event-queue-listen ((eq standard-event-queue))
188 (not (null (event-queue-head eq))))
189
190 (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)
191 (or (not (null (event-queue-peek eq)))
192 (flet ((pred ()
193 (not (null (event-queue-head eq)))))
194 (if timeout
195 (process-wait-with-timeout "Listening for event" timeout #'pred)
196 (progn
197 (process-wait "Listening for event" #'pred)
198 t)))))
199
200
201 ;; STANDARD-SHEET-INPUT-MIXIN
202
203 (defclass standard-sheet-input-mixin ()
204 ((queue :initform (make-instance 'standard-event-queue)
205 :reader sheet-event-queue
206 :initarg :input-buffer)
207 (port :initform nil
208 :initarg :port
209 :reader port)))
210
211 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
212 (sheet-event-queue stream))
213
214 (defmethod (setf stream-input-buffer) (new-val
215 (stream standard-sheet-input-mixin))
216 (setf (slot-value stream 'queue) new-val))
217
218 ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
219 ; (if (typep event 'device-event)
220 ; (queue-event sheet event)
221 ; (handle-event sheet event)))
222
223 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
224 (queue-event sheet event))
225
226 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
227 (with-slots (queue) sheet
228 (event-queue-append queue event)))
229
230 (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
231 ;; Standard practice is to ignore events
232 (declare (ignore event))
233 nil)
234
235 (defmethod event-read ((sheet standard-sheet-input-mixin))
236 (with-slots (queue) sheet
237 (event-queue-read queue)))
238
239 (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
240 &key (timeout nil) (wait-function nil))
241 ;; This one is not in the spec ;-( --GB
242 (with-slots (queue) sheet
243 (event-queue-read-with-timeout queue timeout wait-function)))
244
245 (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
246 (with-slots (queue) sheet
247 (event-queue-read-no-hang queue)))
248
249 (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
250 (with-slots (queue) sheet
251 (if event-type
252 (event-queue-peek-if (lambda (x)
253 (typep x event-type))
254 queue)
255 (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
256 queue))))
257
258 (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
259 (with-slots (queue) sheet
260 (event-queue-prepend queue event)))
261
262 (defmethod event-listen ((sheet standard-sheet-input-mixin))
263 (with-slots (queue) sheet
264 (event-queue-listen queue)))
265
266 ;;;;
267
268 ;;; Support for callers that want to set an event queue for every pane.
269
270 (defclass no-event-queue-mixin ()
271 ())
272
273 (defmethod initialize-instance :after ((obj no-event-queue-mixin)
274 &key input-buffer)
275 (declare (ignore input-buffer))
276 nil)
277
278 (defmethod (setf stream-input-buffer) (new-val (stream no-event-queue-mixin))
279 new-val)
280
281 (defclass immediate-sheet-input-mixin (no-event-queue-mixin)
282 ())
283
284 (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
285 (handle-event sheet event))
286
287 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
288 (declare (ignore event))
289 nil)
290
291 (define-condition sheet-is-mute-for-input (error)
292 ())
293
294 (defclass sheet-mute-input-mixin (no-event-queue-mixin)
295 ())
296
297 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
298 (declare (ignore event))
299 (error 'sheet-is-mute-for-input))
300
301 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
302 (declare (ignore event))
303 (error 'sheet-is-mute-for-input))
304
305 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
306 (declare (ignore event))
307 (error 'sheet-is-mute-for-input))
308
309 (defmethod event-read ((sheet sheet-mute-input-mixin))
310 (error 'sheet-is-mute-for-input))
311
312 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
313 &key (timeout nil) (wait-function nil))
314 (declare (ignore timeout wait-function))
315 (error 'sheet-is-mute-for-input))
316
317 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
318 (error 'sheet-is-mute-for-input))
319
320 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
321 (declare (ignore event-type))
322 (error 'sheet-is-mute-for-input))
323
324 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
325 (declare (ignore event))
326 (error 'sheet-is-mute-for-input))
327
328 (defmethod event-listen ((sheet sheet-mute-input-mixin))
329 (error 'sheet-is-mute-for-input))
330
331 ;;;;
332
333 (defclass delegate-sheet-input-mixin ()
334 ((delegate :initform nil
335 :initarg :delegate
336 :accessor delegate-sheet-delegate) ))
337
338 ;;; Don't know if this event queue stuff is completely right, or if it matters
339 ;;; much...
340
341 (defmethod initialize-instance :after ((obj delegate-sheet-input-mixin)
342 &key input-buffer)
343 (declare (ignore input-buffer)))
344
345 (defmethod stream-input-buffer ((stream delegate-sheet-input-mixin))
346 (sheet-event-queue (delegate-sheet-delegate stream)))
347
348 (defmethod (setf stream-input-buffer) (new-val
349 (stream delegate-sheet-input-mixin))
350 (setf (stream-input-buffer (delegate-sheet-delegate stream)) new-val))
351
352 (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
353 (dispatch-event (delegate-sheet-delegate sheet) event))
354
355 (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
356 (queue-event (delegate-sheet-delegate sheet) event))
357
358 (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
359 (handle-event (delegate-sheet-delegate sheet) event))
360
361 (defmethod event-read ((sheet delegate-sheet-input-mixin))
362 (event-read (delegate-sheet-delegate sheet)))
363
364 (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
365 &key (timeout nil) (wait-function nil))
366 (event-read-with-timeout (delegate-sheet-delegate sheet)
367 :timeout timeout :wait-function wait-function))
368
369 (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
370 (event-read-no-hang (delegate-sheet-delegate sheet)))
371
372 (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
373 (event-peek (delegate-sheet-delegate sheet) event-type))
374
375 (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
376 (event-unread (delegate-sheet-delegate sheet) event))
377
378 (defmethod event-listen ((sheet delegate-sheet-input-mixin))
379 (event-listen (delegate-sheet-delegate sheet)))
380
381 ;;; Class actually used by panes.
382
383 (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)
384 ())

  ViewVC Help
Powered by ViewVC 1.1.5