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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.27 - (show annotations)
Wed Nov 5 11:31:38 2003 UTC (10 years, 5 months ago) by hefner1
Branch: MAIN
Changes since 1.26: +11 -7 lines
Cleanups related to port-force-output - adopt/disown-frame are the correct
places to change a queue's port. Also, avoid a trip into the debugger in
case somehow these do not get set, since flushing the output buffer is
optional.
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 initialize-instance :after ((sheet standard-sheet-input-mixin)
357 &rest args)
358 (declare (ignore args))
359 (setf (event-queue-port (sheet-event-queue sheet)) (port sheet)))
360
361
362 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
363 (sheet-event-queue stream))
364
365 (defmethod (setf stream-input-buffer) (new-val
366 (stream standard-sheet-input-mixin))
367 (setf (slot-value stream 'queue) new-val))
368
369 ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
370 ; (if (typep event 'device-event)
371 ; (queue-event sheet event)
372 ; (handle-event sheet event)))
373
374 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
375 (queue-event sheet event))
376
377 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
378 (with-slots (queue) sheet
379 (event-queue-append queue event)))
380
381 (defmethod schedule-event ((sheet standard-sheet-input-mixin) event delay)
382 (with-slots (queue) sheet
383 (schedule-event-queue queue sheet event delay)))
384
385 (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
386 ;; Standard practice is to ignore events
387 (declare (ignore event))
388 nil)
389
390 (defmethod event-read ((sheet standard-sheet-input-mixin))
391 (with-slots (queue) sheet
392 (event-queue-read queue)))
393
394 (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
395 &key (timeout nil) (wait-function nil))
396 ;; This one is not in the spec ;-( --GB
397 (with-slots (queue) sheet
398 (event-queue-read-with-timeout queue timeout wait-function)))
399
400 (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
401 (with-slots (queue) sheet
402 (event-queue-read-no-hang queue)))
403
404 (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
405 (with-slots (queue) sheet
406 (if event-type
407 (event-queue-peek-if (lambda (x)
408 (typep x event-type))
409 queue)
410 (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
411 queue))))
412
413 (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
414 (with-slots (queue) sheet
415 (event-queue-prepend queue event)))
416
417 (defmethod event-listen ((sheet standard-sheet-input-mixin))
418 (with-slots (queue) sheet
419 (event-queue-listen queue)))
420
421 ;;;;
422
423 ;;; Support for callers that want to set an event queue for every pane.
424
425 (defclass no-event-queue-mixin ()
426 ())
427
428 (defmethod initialize-instance :after ((obj no-event-queue-mixin)
429 &key input-buffer)
430 (declare (ignore input-buffer))
431 nil)
432
433 (defmethod (setf stream-input-buffer) (new-val (stream no-event-queue-mixin))
434 new-val)
435
436 (defclass immediate-sheet-input-mixin (no-event-queue-mixin)
437 ())
438
439 (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
440 (handle-event sheet event))
441
442 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
443 (declare (ignore event))
444 nil)
445
446 (define-condition sheet-is-mute-for-input (error)
447 ())
448
449 (defclass sheet-mute-input-mixin (no-event-queue-mixin)
450 ())
451
452 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
453 (declare (ignore event))
454 (error 'sheet-is-mute-for-input))
455
456 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
457 (declare (ignore event))
458 (error 'sheet-is-mute-for-input))
459
460 (defmethod schedule-event ((sheet sheet-mute-input-mixin) event delay)
461 (declare (ignore event delay))
462 (error 'sheet-is-mute-for-input))
463
464 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
465 (declare (ignore event))
466 (error 'sheet-is-mute-for-input))
467
468 (defmethod event-read ((sheet sheet-mute-input-mixin))
469 (error 'sheet-is-mute-for-input))
470
471 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
472 &key (timeout nil) (wait-function nil))
473 (declare (ignore timeout wait-function))
474 (error 'sheet-is-mute-for-input))
475
476 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
477 (error 'sheet-is-mute-for-input))
478
479 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
480 (declare (ignore event-type))
481 (error 'sheet-is-mute-for-input))
482
483 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
484 (declare (ignore event))
485 (error 'sheet-is-mute-for-input))
486
487 (defmethod event-listen ((sheet sheet-mute-input-mixin))
488 (error 'sheet-is-mute-for-input))
489
490 ;;;;
491
492 (defclass delegate-sheet-input-mixin ()
493 ((delegate :initform nil
494 :initarg :delegate
495 :accessor delegate-sheet-delegate) ))
496
497 ;;; Don't know if this event queue stuff is completely right, or if it matters
498 ;;; much...
499
500 (defmethod initialize-instance :after ((obj delegate-sheet-input-mixin)
501 &key input-buffer)
502 (declare (ignore input-buffer)))
503
504 (defmethod stream-input-buffer ((stream delegate-sheet-input-mixin))
505 (sheet-event-queue (delegate-sheet-delegate stream)))
506
507 (defmethod (setf stream-input-buffer) (new-val
508 (stream delegate-sheet-input-mixin))
509 (setf (stream-input-buffer (delegate-sheet-delegate stream)) new-val))
510
511 (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
512 (dispatch-event (delegate-sheet-delegate sheet) event))
513
514 (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
515 (queue-event (delegate-sheet-delegate sheet) event))
516
517 (defmethod schedule-event ((sheet delegate-sheet-input-mixin) event delay)
518 (schedule-event (delegate-sheet-delegate sheet) event delay))
519
520 (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
521 (handle-event (delegate-sheet-delegate sheet) event))
522
523 (defmethod event-read ((sheet delegate-sheet-input-mixin))
524 (event-read (delegate-sheet-delegate sheet)))
525
526 (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
527 &key (timeout nil) (wait-function nil))
528 (event-read-with-timeout (delegate-sheet-delegate sheet)
529 :timeout timeout :wait-function wait-function))
530
531 (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
532 (event-read-no-hang (delegate-sheet-delegate sheet)))
533
534 (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
535 (event-peek (delegate-sheet-delegate sheet) event-type))
536
537 (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
538 (event-unread (delegate-sheet-delegate sheet) event))
539
540 (defmethod event-listen ((sheet delegate-sheet-input-mixin))
541 (event-listen (delegate-sheet-delegate sheet)))
542
543 ;;; Class actually used by panes.
544
545 (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)
546 ())

  ViewVC Help
Powered by ViewVC 1.1.5