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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.26 - (show annotations)
Mon Nov 3 08:12:34 2003 UTC (10 years, 5 months ago) by strandh
Branch: MAIN
Changes since 1.25: +1 -0 lines
Added a few "ignore" declarations to avoid compiler notes.
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 ; experimental extension for scheduled event insersion
37 (schedule-time
38 :initform nil
39 :accessor event-schedule-time
40 :documentation "The next time an event should be scheduled.")
41 (schedule
42 :initform nil
43 ;; :accessor event-queue-schedule
44 ;; this accessor conflicts with the method below.
45 ;; noted by mikemac. I recommend renaming the slot.
46 ;; --GB 2002-11-10
47 :documentation "Time ordered queue of events to schedule.")))
48
49 (defclass port-event-queue (standard-event-queue)
50 ((port :initform nil
51 :initarg :port
52 :accessor event-queue-port
53 :documentation "The port which will be generating events for the queue.")))
54
55 (defmethod event-queue-read-no-hang ((eq standard-event-queue))
56 "Reads one event from the queue, if there is no event just return NIL."
57 (with-lock-held ((event-queue-lock eq))
58 (check-schedule eq)
59 (let ((res (pop (event-queue-head eq))))
60 (when (null (event-queue-head eq))
61 (setf (event-queue-tail eq) nil))
62 res)))
63
64 (defmethod event-queue-read ((eq standard-event-queue))
65 "Reads one event from the queue, if there is no event, hang until here is one."
66 (loop
67 (check-schedule eq)
68 (let ((res (event-queue-read-no-hang eq)))
69 (when res
70 (return res))
71 ; is there an event waiting to be scheduled?
72 (with-slots (schedule-time) eq
73 (let* ((now (now))
74 (timeout (when schedule-time (- schedule-time now))))
75 (if timeout
76 (if *multiprocessing-p*
77 (process-wait-with-timeout "Waiting for event"
78 timeout
79 (lambda ()
80 (not (null (event-queue-head eq)))))
81 (process-wait-with-timeout "Waiting for event"
82 timeout
83 (lambda ()
84 (loop for port in climi::*all-ports*
85 ; this is dubious
86 do (process-next-event port))
87 (not (null (event-queue-head eq))))))
88 ; no timeout
89 (if *multiprocessing-p*
90 (process-wait "Waiting for event"
91 (lambda ()
92 (not (null (event-queue-head eq)))))
93 (process-wait "Waiting for event"
94 (lambda ()
95 (loop for port in climi::*all-ports*
96 ; this is dubious
97 do (process-next-event port))
98 (not (null (event-queue-head eq))))))))))))
99
100 (defmethod event-queue-read-with-timeout ((eq standard-event-queue)
101 timeout wait-function)
102 (loop
103 (check-schedule eq)
104 (let ((res (event-queue-read-no-hang eq)))
105 (when res
106 (return res))
107 (if *multiprocessing-p*
108 (process-wait-with-timeout "Waiting for event"
109 timeout
110 (lambda ()
111 (or
112 (not (null (event-queue-head eq)))
113 (funcall wait-function))))
114 (process-wait-with-timeout "Waiting for event"
115 timeout
116 (lambda ()
117 (loop for port in climi::*all-ports*
118 ;; this is dubious
119 do (process-next-event port))
120 (or
121 (not (null (event-queue-head eq)))
122 (funcall wait-function))))))))
123
124 (defmethod event-queue-append ((eq standard-event-queue) item)
125 "Append the item at the end of the queue. Does event compression."
126 (with-lock-held ((event-queue-lock eq))
127 (labels ((append-event ()
128 (cond ((null (event-queue-tail eq))
129 (setf (event-queue-head eq) (cons item nil)
130 (event-queue-tail eq) (event-queue-head eq)))
131 (t
132 (setf (event-queue-tail eq)
133 (setf (cdr (event-queue-tail eq)) (cons item nil))))))
134 (event-delete-if (predicate)
135 (when (not (null (event-queue-head eq)))
136 (setf (event-queue-head eq)
137 (delete-if predicate (event-queue-head eq))
138 (event-queue-tail eq)
139 (last (event-queue-head eq))))))
140 (cond
141 ;; Motion Event Compression
142 ;;
143 ;; . find the (at most one) motion event
144 ;; . delete it
145 ;; . append item to queue
146 ;;
147 ;; But leave enter/exit events.
148 ;;
149 ((and (typep item 'pointer-motion-event)
150 (not (typep item 'pointer-boundary-event)))
151 (let ((sheet (event-sheet item)))
152 (event-delete-if
153 #'(lambda (x)
154 (and (typep x 'pointer-motion-event)
155 (not (typep x 'pointer-boundary-event))
156 (eq (event-sheet x) sheet))))
157 (append-event)))
158 ;;
159 ;; Resize event compression
160 ;;
161 ((typep item 'window-configuration-event)
162 (when (typep (event-sheet item) 'top-level-sheet-pane)
163 (let ((sheet (event-sheet item)))
164 (event-delete-if
165 #'(lambda (ev)
166 (and (typep ev 'window-configuration-event)
167 (eq (event-sheet ev) sheet)))))
168 (append-event)))
169 ;;
170 ;; Repaint event compression
171 ;;
172 ((typep item 'window-repaint-event)
173 (let ((region (window-event-native-region item))
174 (sheet (event-sheet item))
175 (did-something-p nil))
176 (labels ((fun (xs)
177 (cond ((null xs)
178 ;; We reached the queue's tail: Append the new event, construct a new
179 ;; one if necessary.
180 (when did-something-p
181 (setf item
182 (make-instance 'window-repaint-event
183 :timestamp (event-timestamp item)
184 :sheet (event-sheet item)
185 :region region)))
186 (setf (event-queue-tail eq) (cons item nil)) )
187 ;;
188 ((and (typep (car xs) 'window-repaint-event)
189 (eq (event-sheet (car xs)) sheet))
190 ;; This is a repaint event for the same sheet, delete it and combine
191 ;; its region into the new event.
192 (setf region
193 (region-union region (window-event-native-region (car xs))))
194 ;; Here is an alternative, which just takes the bounding rectangle.
195 ;; NOTE: When doing this also take care that the new region really
196 ;; is cleared.
197 ;; (setf region
198 ;; (let ((old-region (window-event-native-region (car xs))))
199 ;; (make-rectangle*
200 ;; (min (bounding-rectangle-min-x region)
201 ;; (bounding-rectangle-min-x old-region))
202 ;; (min (bounding-rectangle-min-y region)
203 ;; (bounding-rectangle-min-y old-region))
204 ;; (max (bounding-rectangle-max-x region)
205 ;; (bounding-rectangle-max-x old-region))
206 ;; (max (bounding-rectangle-max-y region)
207 ;; (bounding-rectangle-max-y old-region)))))
208 (setf did-something-p t)
209 (fun (cdr xs)))
210 ;;
211 (t
212 (setf (cdr xs) (fun (cdr xs)))
213 xs))))
214 (setf (event-queue-head eq) (fun (event-queue-head eq))))))
215 ;; Regular events are just appended:
216 (t (append-event))))))
217
218 (defmethod event-queue-prepend ((eq standard-event-queue) item)
219 "Prepend the item to the beginning of the queue."
220 (with-lock-held ((event-queue-lock eq))
221 (cond ((null (event-queue-tail eq))
222 (setf (event-queue-head eq) (cons item nil)
223 (event-queue-tail eq) (event-queue-head eq)))
224 (t
225 (push item (event-queue-head eq))))))
226
227 (defmethod event-queue-peek ((eq standard-event-queue))
228 (with-lock-held ((event-queue-lock eq))
229 (check-schedule eq)
230 (first (event-queue-head eq))))
231
232 (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
233 "Goes thru the whole event queue and returns the first event, which
234 satisfies 'predicate' and leaves the event in the queue.
235 Returns NIL, if there is no such event."
236 (with-lock-held ((event-queue-lock eq))
237 (find-if predicate (event-queue-head eq))))
238
239 (defmethod event-queue-listen ((eq standard-event-queue))
240 (check-schedule eq)
241 (not (null (event-queue-head eq))))
242
243 (defun now ()
244 (/ (get-internal-real-time)
245 internal-time-units-per-second))
246
247 (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)
248 (check-schedule eq)
249 (with-slots (schedule-time) eq
250 (flet ((pred ()
251 (not (null (event-queue-head eq)))))
252 (cond
253 (timeout
254 (loop as timeout-time = (+ now timeout)
255 with now = (now)
256 do (when (pred)
257 (return t))
258 do (when (>= now timeout-time)
259 (return nil))
260 do (let ((timeout (if schedule-time
261 (min (- schedule-time now)
262 (- timeout-time now))
263 (- timeout-time now))))
264 (process-wait-with-timeout "Listening for event" timeout #'pred))
265 do (check-schedule eq)))
266 (schedule-time
267 (loop do (when (pred)
268 (return t))
269 do (process-wait-with-timeout "Listening for event"
270 (- schedule-time (now)) #'pred)
271 do (check-schedule eq)))
272 (t
273 (or (pred)
274 (progn
275 (process-wait "Listening for event" #'pred)
276 t)))))))
277
278 (defmethod check-schedule ((eq standard-event-queue))
279 ; see if it's time to inject a scheduled event into the queue.
280 (with-slots (schedule-time schedule) eq
281 (when (and schedule-time
282 (> (now) schedule-time))
283 (let* ((event (pop schedule))
284 (sheet (pop schedule)))
285 (setf schedule-time (pop schedule))
286 (dispatch-event sheet event))
287 t)))
288
289 ; ugh. FIXME when I work - build a priority queue or something
290 (defmethod schedule-event-queue ((eq standard-event-queue) sheet event delay)
291 (with-slots (schedule-time schedule) eq
292 (let ((when (+ (now) delay)))
293 (if schedule
294 (cond
295 ((< when schedule-time)
296 (push schedule-time schedule)
297 (push sheet schedule)
298 (push event schedule)
299 (setf schedule-time when))
300 (t
301 ; (format *trace-output* "queue = ~A~%" schedule)
302 (do* ((prev (cdr schedule) (cdddr prev))
303 (point (cddr schedule) (cdddr point))
304 (time (car point)))
305 ((or (null point)
306 (< when time))
307 (setf (cdr prev)
308 (cons when (cons event (cons sheet (cdr prev)))))))))
309 (progn
310 (setf schedule-time when)
311 (push sheet schedule)
312 (push event schedule))))))
313
314 ;; PORT-EVENT-QUEUE methods
315
316 (defmethod event-queue-read :before ((eq port-event-queue))
317 (port-force-output (event-queue-port eq)))
318
319 (defmethod event-queue-read-no-hang :before ((eq port-event-queue))
320 (port-force-output (event-queue-port eq)))
321
322 (defmethod event-queue-read-with-timeout :before ((eq port-event-queue)
323 timeout wait-function)
324 (declare (ignore timeout wait-function))
325 (port-force-output (event-queue-port eq)))
326
327 (defmethod event-queue-listen :before ((eq port-event-queue))
328 (port-force-output (event-queue-port eq)))
329
330 (defmethod event-queue-listen-or-wait :before ((eq standard-event-queue)
331 &key timeout)
332 (declare (ignore timeout))
333 (port-force-output (event-queue-port eq)))
334
335 (defmethod event-queue-peek :before ((eq port-event-queue))
336 (port-force-output (event-queue-port eq)))
337
338 (defmethod event-queue-peek-if :before (predicate (eq port-event-queue))
339 (declare (ignore predicate))
340 (port-force-output (event-queue-port eq)))
341
342 ;; STANDARD-SHEET-INPUT-MIXIN
343
344 (defclass standard-sheet-input-mixin ()
345 ((queue :initform (make-instance 'port-event-queue)
346 :reader sheet-event-queue
347 :initarg :input-buffer)
348 (port :initform nil
349 :initarg :port
350 :reader port)))
351
352 (defmethod initialize-instance :after ((sheet standard-sheet-input-mixin)
353 &rest args)
354 (declare (ignore args))
355 (setf (event-queue-port (sheet-event-queue sheet)) (port sheet)))
356
357
358 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
359 (sheet-event-queue stream))
360
361 (defmethod (setf stream-input-buffer) (new-val
362 (stream standard-sheet-input-mixin))
363 (setf (slot-value stream 'queue) new-val))
364
365 ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
366 ; (if (typep event 'device-event)
367 ; (queue-event sheet event)
368 ; (handle-event sheet event)))
369
370 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
371 (queue-event sheet event))
372
373 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
374 (with-slots (queue) sheet
375 (event-queue-append queue event)))
376
377 (defmethod schedule-event ((sheet standard-sheet-input-mixin) event delay)
378 (with-slots (queue) sheet
379 (schedule-event-queue queue sheet event delay)))
380
381 (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
382 ;; Standard practice is to ignore events
383 (declare (ignore event))
384 nil)
385
386 (defmethod event-read ((sheet standard-sheet-input-mixin))
387 (with-slots (queue) sheet
388 (event-queue-read queue)))
389
390 (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
391 &key (timeout nil) (wait-function nil))
392 ;; This one is not in the spec ;-( --GB
393 (with-slots (queue) sheet
394 (event-queue-read-with-timeout queue timeout wait-function)))
395
396 (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
397 (with-slots (queue) sheet
398 (event-queue-read-no-hang queue)))
399
400 (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
401 (with-slots (queue) sheet
402 (if event-type
403 (event-queue-peek-if (lambda (x)
404 (typep x event-type))
405 queue)
406 (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
407 queue))))
408
409 (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
410 (with-slots (queue) sheet
411 (event-queue-prepend queue event)))
412
413 (defmethod event-listen ((sheet standard-sheet-input-mixin))
414 (with-slots (queue) sheet
415 (event-queue-listen queue)))
416
417 ;;;;
418
419 ;;; Support for callers that want to set an event queue for every pane.
420
421 (defclass no-event-queue-mixin ()
422 ())
423
424 (defmethod initialize-instance :after ((obj no-event-queue-mixin)
425 &key input-buffer)
426 (declare (ignore input-buffer))
427 nil)
428
429 (defmethod (setf stream-input-buffer) (new-val (stream no-event-queue-mixin))
430 new-val)
431
432 (defclass immediate-sheet-input-mixin (no-event-queue-mixin)
433 ())
434
435 (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
436 (handle-event sheet event))
437
438 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
439 (declare (ignore event))
440 nil)
441
442 (define-condition sheet-is-mute-for-input (error)
443 ())
444
445 (defclass sheet-mute-input-mixin (no-event-queue-mixin)
446 ())
447
448 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
449 (declare (ignore event))
450 (error 'sheet-is-mute-for-input))
451
452 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
453 (declare (ignore event))
454 (error 'sheet-is-mute-for-input))
455
456 (defmethod schedule-event ((sheet sheet-mute-input-mixin) event delay)
457 (declare (ignore event delay))
458 (error 'sheet-is-mute-for-input))
459
460 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
461 (declare (ignore event))
462 (error 'sheet-is-mute-for-input))
463
464 (defmethod event-read ((sheet sheet-mute-input-mixin))
465 (error 'sheet-is-mute-for-input))
466
467 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
468 &key (timeout nil) (wait-function nil))
469 (declare (ignore timeout wait-function))
470 (error 'sheet-is-mute-for-input))
471
472 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
473 (error 'sheet-is-mute-for-input))
474
475 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
476 (declare (ignore event-type))
477 (error 'sheet-is-mute-for-input))
478
479 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
480 (declare (ignore event))
481 (error 'sheet-is-mute-for-input))
482
483 (defmethod event-listen ((sheet sheet-mute-input-mixin))
484 (error 'sheet-is-mute-for-input))
485
486 ;;;;
487
488 (defclass delegate-sheet-input-mixin ()
489 ((delegate :initform nil
490 :initarg :delegate
491 :accessor delegate-sheet-delegate) ))
492
493 ;;; Don't know if this event queue stuff is completely right, or if it matters
494 ;;; much...
495
496 (defmethod initialize-instance :after ((obj delegate-sheet-input-mixin)
497 &key input-buffer)
498 (declare (ignore input-buffer)))
499
500 (defmethod stream-input-buffer ((stream delegate-sheet-input-mixin))
501 (sheet-event-queue (delegate-sheet-delegate stream)))
502
503 (defmethod (setf stream-input-buffer) (new-val
504 (stream delegate-sheet-input-mixin))
505 (setf (stream-input-buffer (delegate-sheet-delegate stream)) new-val))
506
507 (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
508 (dispatch-event (delegate-sheet-delegate sheet) event))
509
510 (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
511 (queue-event (delegate-sheet-delegate sheet) event))
512
513 (defmethod schedule-event ((sheet delegate-sheet-input-mixin) event delay)
514 (schedule-event (delegate-sheet-delegate sheet) event delay))
515
516 (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
517 (handle-event (delegate-sheet-delegate sheet) event))
518
519 (defmethod event-read ((sheet delegate-sheet-input-mixin))
520 (event-read (delegate-sheet-delegate sheet)))
521
522 (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
523 &key (timeout nil) (wait-function nil))
524 (event-read-with-timeout (delegate-sheet-delegate sheet)
525 :timeout timeout :wait-function wait-function))
526
527 (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
528 (event-read-no-hang (delegate-sheet-delegate sheet)))
529
530 (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
531 (event-peek (delegate-sheet-delegate sheet) event-type))
532
533 (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
534 (event-unread (delegate-sheet-delegate sheet) event))
535
536 (defmethod event-listen ((sheet delegate-sheet-input-mixin))
537 (event-listen (delegate-sheet-delegate sheet)))
538
539 ;;; Class actually used by panes.
540
541 (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)
542 ())

  ViewVC Help
Powered by ViewVC 1.1.5