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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (show annotations)
Sun Dec 16 23:20:10 2007 UTC (6 years, 4 months ago) by dlichteblau
Branch: MAIN
CVS Tags: McCLIM-0-9-6, HEAD
Changes since 1.38: +2 -1 lines
Fixed EVENT-QUEUE-READ-WITH-TIMEOUT to return on timeout.  Previously it
would just continue silently.

	* input.lisp (EVENT-QUEUE-READ-WITH-TIMEOUT): return if
	condition-wait returns nil.

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

  ViewVC Help
Powered by ViewVC 1.1.5