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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (show annotations)
Sat Nov 8 01:06:51 2003 UTC (10 years, 5 months ago) by hefner1
Branch: MAIN
CVS Tags: McCLIM-0-9
Changes since 1.27: +0 -6 lines
Oops, single-threaded CLIM uses a different input mixin on sheets.
Conditionalized some event queue querying so that hopefully it doesn't
break in that situation.
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 (defun do-port-force-output (port-event-queue)
317 (let ((port (event-queue-port port-event-queue)))
318 (when port (port-force-output port))))
319
320 (defmethod event-queue-read :before ((eq port-event-queue))
321 (do-port-force-output eq))
322
323 (defmethod event-queue-read-no-hang :before ((eq port-event-queue))
324 (do-port-force-output eq))
325
326 (defmethod event-queue-read-with-timeout :before ((eq port-event-queue)
327 timeout wait-function)
328 (declare (ignore timeout wait-function))
329 (do-port-force-output eq))
330
331 (defmethod event-queue-listen :before ((eq port-event-queue))
332 (do-port-force-output eq))
333
334 (defmethod event-queue-listen-or-wait :before ((eq standard-event-queue)
335 &key timeout)
336 (declare (ignore timeout))
337 (do-port-force-output eq))
338
339 (defmethod event-queue-peek :before ((eq port-event-queue))
340 (do-port-force-output eq))
341
342 (defmethod event-queue-peek-if :before (predicate (eq port-event-queue))
343 (declare (ignore predicate))
344 (do-port-force-output eq))
345
346 ;; STANDARD-SHEET-INPUT-MIXIN
347
348 (defclass standard-sheet-input-mixin ()
349 ((queue :initform (make-instance 'port-event-queue)
350 :reader sheet-event-queue
351 :initarg :input-buffer)
352 (port :initform nil
353 :initarg :port
354 :reader port)))
355
356 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
357 (sheet-event-queue stream))
358
359 (defmethod (setf stream-input-buffer) (new-val
360 (stream standard-sheet-input-mixin))
361 (setf (slot-value stream 'queue) new-val))
362
363 ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
364 ; (if (typep event 'device-event)
365 ; (queue-event sheet event)
366 ; (handle-event sheet event)))
367
368 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
369 (queue-event sheet event))
370
371 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
372 (with-slots (queue) sheet
373 (event-queue-append queue event)))
374
375 (defmethod schedule-event ((sheet standard-sheet-input-mixin) event delay)
376 (with-slots (queue) sheet
377 (schedule-event-queue queue sheet event delay)))
378
379 (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
380 ;; Standard practice is to ignore events
381 (declare (ignore event))
382 nil)
383
384 (defmethod event-read ((sheet standard-sheet-input-mixin))
385 (with-slots (queue) sheet
386 (event-queue-read queue)))
387
388 (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
389 &key (timeout nil) (wait-function nil))
390 ;; This one is not in the spec ;-( --GB
391 (with-slots (queue) sheet
392 (event-queue-read-with-timeout queue timeout wait-function)))
393
394 (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
395 (with-slots (queue) sheet
396 (event-queue-read-no-hang queue)))
397
398 (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
399 (with-slots (queue) sheet
400 (if event-type
401 (event-queue-peek-if (lambda (x)
402 (typep x event-type))
403 queue)
404 (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
405 queue))))
406
407 (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
408 (with-slots (queue) sheet
409 (event-queue-prepend queue event)))
410
411 (defmethod event-listen ((sheet standard-sheet-input-mixin))
412 (with-slots (queue) sheet
413 (event-queue-listen queue)))
414
415 ;;;;
416
417 ;;; Support for callers that want to set an event queue for every pane.
418
419 (defclass no-event-queue-mixin ()
420 ())
421
422 (defmethod initialize-instance :after ((obj no-event-queue-mixin)
423 &key input-buffer)
424 (declare (ignore input-buffer))
425 nil)
426
427 (defmethod (setf stream-input-buffer) (new-val (stream no-event-queue-mixin))
428 new-val)
429
430 (defclass immediate-sheet-input-mixin (no-event-queue-mixin)
431 ())
432
433 (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
434 (handle-event sheet event))
435
436 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
437 (declare (ignore event))
438 nil)
439
440 (define-condition sheet-is-mute-for-input (error)
441 ())
442
443 (defclass sheet-mute-input-mixin (no-event-queue-mixin)
444 ())
445
446 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
447 (declare (ignore event))
448 (error 'sheet-is-mute-for-input))
449
450 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
451 (declare (ignore event))
452 (error 'sheet-is-mute-for-input))
453
454 (defmethod schedule-event ((sheet sheet-mute-input-mixin) event delay)
455 (declare (ignore event delay))
456 (error 'sheet-is-mute-for-input))
457
458 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
459 (declare (ignore event))
460 (error 'sheet-is-mute-for-input))
461
462 (defmethod event-read ((sheet sheet-mute-input-mixin))
463 (error 'sheet-is-mute-for-input))
464
465 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
466 &key (timeout nil) (wait-function nil))
467 (declare (ignore timeout wait-function))
468 (error 'sheet-is-mute-for-input))
469
470 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
471 (error 'sheet-is-mute-for-input))
472
473 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
474 (declare (ignore event-type))
475 (error 'sheet-is-mute-for-input))
476
477 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
478 (declare (ignore event))
479 (error 'sheet-is-mute-for-input))
480
481 (defmethod event-listen ((sheet sheet-mute-input-mixin))
482 (error 'sheet-is-mute-for-input))
483
484 ;;;;
485
486 (defclass delegate-sheet-input-mixin ()
487 ((delegate :initform nil
488 :initarg :delegate
489 :accessor delegate-sheet-delegate) ))
490
491 ;;; Don't know if this event queue stuff is completely right, or if it matters
492 ;;; much...
493
494 (defmethod initialize-instance :after ((obj delegate-sheet-input-mixin)
495 &key input-buffer)
496 (declare (ignore input-buffer)))
497
498 (defmethod stream-input-buffer ((stream delegate-sheet-input-mixin))
499 (sheet-event-queue (delegate-sheet-delegate stream)))
500
501 (defmethod (setf stream-input-buffer) (new-val
502 (stream delegate-sheet-input-mixin))
503 (setf (stream-input-buffer (delegate-sheet-delegate stream)) new-val))
504
505 (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
506 (dispatch-event (delegate-sheet-delegate sheet) event))
507
508 (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
509 (queue-event (delegate-sheet-delegate sheet) event))
510
511 (defmethod schedule-event ((sheet delegate-sheet-input-mixin) event delay)
512 (schedule-event (delegate-sheet-delegate sheet) event delay))
513
514 (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
515 (handle-event (delegate-sheet-delegate sheet) event))
516
517 (defmethod event-read ((sheet delegate-sheet-input-mixin))
518 (event-read (delegate-sheet-delegate sheet)))
519
520 (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
521 &key (timeout nil) (wait-function nil))
522 (event-read-with-timeout (delegate-sheet-delegate sheet)
523 :timeout timeout :wait-function wait-function))
524
525 (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
526 (event-read-no-hang (delegate-sheet-delegate sheet)))
527
528 (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
529 (event-peek (delegate-sheet-delegate sheet) event-type))
530
531 (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
532 (event-unread (delegate-sheet-delegate sheet) event))
533
534 (defmethod event-listen ((sheet delegate-sheet-input-mixin))
535 (event-listen (delegate-sheet-delegate sheet)))
536
537 ;;; Class actually used by panes.
538
539 (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)
540 ())

  ViewVC Help
Powered by ViewVC 1.1.5