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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5