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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.38 - (hide annotations)
Sun Dec 16 22:41:51 2007 UTC (6 years, 4 months ago) by dlichteblau
Branch: MAIN
Changes since 1.37: +2 -2 lines
In EVENT-QUEUE-READ-WITH-TIMEOUT, warn about the WAIT-FUNCTION being
ignored only if a WAIT-FUNCTION was specified.
1 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3     ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
4 gilbert 1.5 ;;; (c) copyright 2002 by Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
5 mikemac 1.1
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 mikemac 1.22 (in-package :clim-internals)
22 mikemac 1.1
23     ;;; Input Protocol Classes
24    
25 gilbert 1.5 ;; 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 brian 1.19 :documentation "Tail pointer of event queue.")
36 moore 1.29 (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 brian 1.19 (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 gilbert 1.20 ;; :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 brian 1.19 :documentation "Time ordered queue of events to schedule.")))
52 gilbert 1.5
53 hefner1 1.25 (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 moore 1.29 (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 gilbert 1.5 (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 moore 1.29 (event-queue-read-no-hang/locked eq)))
70 gilbert 1.5
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 moore 1.29 (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 gilbert 1.5
86 moore 1.31 ;;; 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 gilbert 1.13 (defmethod event-queue-read-with-timeout ((eq standard-event-queue)
90     timeout wait-function)
91 moore 1.29 (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 dlichteblau 1.38 (when wait-function
99     (warn "event-queue-read-with-timeout ignoring predicate"))
100 moore 1.29 (condition-wait (event-queue-processes eq) lock timeout))))))
101 gilbert 1.13
102 gilbert 1.5 (defmethod event-queue-append ((eq standard-event-queue) item)
103 gilbert 1.15 "Append the item at the end of the queue. Does event compression."
104 gilbert 1.5 (with-lock-held ((event-queue-lock eq))
105 hefner1 1.23 (labels ((append-event ()
106     (cond ((null (event-queue-tail eq))
107     (setf (event-queue-head eq) (cons item nil)
108     (event-queue-tail eq) (event-queue-head eq)))
109     (t
110     (setf (event-queue-tail eq)
111     (setf (cdr (event-queue-tail eq)) (cons item nil))))))
112     (event-delete-if (predicate)
113     (when (not (null (event-queue-head eq)))
114     (setf (event-queue-head eq)
115     (delete-if predicate (event-queue-head eq))
116     (event-queue-tail eq)
117     (last (event-queue-head eq))))))
118     (cond
119     ;; Motion Event Compression
120     ;;
121     ;; . find the (at most one) motion event
122     ;; . delete it
123     ;; . append item to queue
124     ;;
125     ;; But leave enter/exit events.
126     ;;
127     ((and (typep item 'pointer-motion-event)
128     (not (typep item 'pointer-boundary-event)))
129     (let ((sheet (event-sheet item)))
130     (event-delete-if
131     #'(lambda (x)
132     (and (typep x 'pointer-motion-event)
133     (not (typep x 'pointer-boundary-event))
134     (eq (event-sheet x) sheet))))
135     (append-event)))
136     ;;
137     ;; Resize event compression
138     ;;
139     ((typep item 'window-configuration-event)
140     (when (typep (event-sheet item) 'top-level-sheet-pane)
141     (let ((sheet (event-sheet item)))
142     (event-delete-if
143     #'(lambda (ev)
144     (and (typep ev 'window-configuration-event)
145     (eq (event-sheet ev) sheet)))))
146     (append-event)))
147     ;;
148     ;; Repaint event compression
149     ;;
150     ((typep item 'window-repaint-event)
151     (let ((region (window-event-native-region item))
152     (sheet (event-sheet item))
153     (did-something-p nil))
154     (labels ((fun (xs)
155     (cond ((null xs)
156 gilbert 1.15 ;; We reached the queue's tail: Append the new event, construct a new
157     ;; one if necessary.
158     (when did-something-p
159     (setf item
160     (make-instance 'window-repaint-event
161     :timestamp (event-timestamp item)
162     :sheet (event-sheet item)
163     :region region)))
164     (setf (event-queue-tail eq) (cons item nil)) )
165     ;;
166     ((and (typep (car xs) 'window-repaint-event)
167     (eq (event-sheet (car xs)) sheet))
168     ;; This is a repaint event for the same sheet, delete it and combine
169     ;; its region into the new event.
170     (setf region
171     (region-union region (window-event-native-region (car xs))))
172     ;; Here is an alternative, which just takes the bounding rectangle.
173     ;; NOTE: When doing this also take care that the new region really
174     ;; is cleared.
175     ;; (setf region
176     ;; (let ((old-region (window-event-native-region (car xs))))
177     ;; (make-rectangle*
178     ;; (min (bounding-rectangle-min-x region)
179     ;; (bounding-rectangle-min-x old-region))
180     ;; (min (bounding-rectangle-min-y region)
181     ;; (bounding-rectangle-min-y old-region))
182     ;; (max (bounding-rectangle-max-x region)
183     ;; (bounding-rectangle-max-x old-region))
184     ;; (max (bounding-rectangle-max-y region)
185     ;; (bounding-rectangle-max-y old-region)))))
186     (setf did-something-p t)
187     (fun (cdr xs)))
188     ;;
189     (t
190     (setf (cdr xs) (fun (cdr xs)))
191     xs))))
192 hefner1 1.23 (setf (event-queue-head eq) (fun (event-queue-head eq))))))
193 gilbert 1.15 ;; Regular events are just appended:
194 moore 1.29 (t (append-event))))
195     (condition-notify (event-queue-processes eq))))
196 gilbert 1.5
197     (defmethod event-queue-prepend ((eq standard-event-queue) item)
198     "Prepend the item to the beginning of the queue."
199     (with-lock-held ((event-queue-lock eq))
200     (cond ((null (event-queue-tail eq))
201     (setf (event-queue-head eq) (cons item nil)
202     (event-queue-tail eq) (event-queue-head eq)))
203     (t
204 moore 1.29 (push item (event-queue-head eq))))
205     (condition-notify (event-queue-processes eq))))
206 gilbert 1.5
207 mikemac 1.7 (defmethod event-queue-peek ((eq standard-event-queue))
208     (with-lock-held ((event-queue-lock eq))
209 brian 1.19 (check-schedule eq)
210 mikemac 1.7 (first (event-queue-head eq))))
211    
212 gilbert 1.5 (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
213 gilbert 1.15 "Goes thru the whole event queue and returns the first event, which
214 gilbert 1.5 satisfies 'predicate' and leaves the event in the queue.
215     Returns NIL, if there is no such event."
216     (with-lock-held ((event-queue-lock eq))
217     (find-if predicate (event-queue-head eq))))
218    
219     (defmethod event-queue-listen ((eq standard-event-queue))
220 brian 1.19 (check-schedule eq)
221 gilbert 1.5 (not (null (event-queue-head eq))))
222    
223 brian 1.19 (defun now ()
224     (/ (get-internal-real-time)
225     internal-time-units-per-second))
226    
227 moore 1.8 (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)
228 brian 1.19 (check-schedule eq)
229 moore 1.29 (let ((lock (event-queue-lock eq)))
230     (with-lock-held (lock)
231 tmoore 1.33 (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     (condition-wait (event-queue-processes eq)
247     lock timeout))
248     do (check-schedule eq)))
249     (schedule-time
250     (loop do (when (pred)
251     (return t))
252     do (condition-wait
253     (event-queue-processes eq) lock (- schedule-time (now)))
254     do (check-schedule eq)))
255     (t
256     (or (pred)
257     (progn
258 moore 1.29 (condition-wait (event-queue-processes eq) lock)
259     t)))))))))
260 brian 1.19
261     (defmethod check-schedule ((eq standard-event-queue))
262     ; see if it's time to inject a scheduled event into the queue.
263     (with-slots (schedule-time schedule) eq
264     (when (and schedule-time
265     (> (now) schedule-time))
266     (let* ((event (pop schedule))
267     (sheet (pop schedule)))
268     (setf schedule-time (pop schedule))
269     (dispatch-event sheet event))
270     t)))
271    
272     ; ugh. FIXME when I work - build a priority queue or something
273 moore 1.21 (defmethod schedule-event-queue ((eq standard-event-queue) sheet event delay)
274 brian 1.19 (with-slots (schedule-time schedule) eq
275     (let ((when (+ (now) delay)))
276     (if schedule
277     (cond
278     ((< when schedule-time)
279     (push schedule-time schedule)
280     (push sheet schedule)
281     (push event schedule)
282     (setf schedule-time when))
283     (t
284 gilbert 1.24 ; (format *trace-output* "queue = ~A~%" schedule)
285 brian 1.19 (do* ((prev (cdr schedule) (cdddr prev))
286     (point (cddr schedule) (cdddr point))
287     (time (car point)))
288     ((or (null point)
289     (< when time))
290     (setf (cdr prev)
291     (cons when (cons event (cons sheet (cdr prev)))))))))
292     (progn
293     (setf schedule-time when)
294     (push sheet schedule)
295     (push event schedule))))))
296 moore 1.8
297 hefner1 1.25 ;; PORT-EVENT-QUEUE methods
298    
299 hefner1 1.27 (defun do-port-force-output (port-event-queue)
300     (let ((port (event-queue-port port-event-queue)))
301     (when port (port-force-output port))))
302    
303 hefner1 1.25 (defmethod event-queue-read :before ((eq port-event-queue))
304 hefner1 1.27 (do-port-force-output eq))
305 hefner1 1.25
306     (defmethod event-queue-read-no-hang :before ((eq port-event-queue))
307 hefner1 1.27 (do-port-force-output eq))
308 hefner1 1.25
309     (defmethod event-queue-read-with-timeout :before ((eq port-event-queue)
310     timeout wait-function)
311     (declare (ignore timeout wait-function))
312 hefner1 1.27 (do-port-force-output eq))
313 hefner1 1.25
314     (defmethod event-queue-listen :before ((eq port-event-queue))
315 hefner1 1.27 (do-port-force-output eq))
316 hefner1 1.25
317     (defmethod event-queue-listen-or-wait :before ((eq standard-event-queue)
318     &key timeout)
319     (declare (ignore timeout))
320 hefner1 1.27 (do-port-force-output eq))
321 hefner1 1.25
322     (defmethod event-queue-peek :before ((eq port-event-queue))
323 hefner1 1.27 (do-port-force-output eq))
324 hefner1 1.25
325     (defmethod event-queue-peek-if :before (predicate (eq port-event-queue))
326     (declare (ignore predicate))
327 hefner1 1.27 (do-port-force-output eq))
328 hefner1 1.25
329 gilbert 1.5 ;; STANDARD-SHEET-INPUT-MIXIN
330    
331 mikemac 1.1 (defclass standard-sheet-input-mixin ()
332 hefner1 1.25 ((queue :initform (make-instance 'port-event-queue)
333 moore 1.14 :reader sheet-event-queue
334     :initarg :input-buffer)
335 mikemac 1.1 (port :initform nil
336     :initarg :port
337 moore 1.14 :reader port)))
338 hefner1 1.25
339 mikemac 1.7 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
340     (sheet-event-queue stream))
341    
342 moore 1.14 (defmethod (setf stream-input-buffer) (new-val
343     (stream standard-sheet-input-mixin))
344     (setf (slot-value stream 'queue) new-val))
345    
346 mikemac 1.7 ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
347     ; (if (typep event 'device-event)
348     ; (queue-event sheet event)
349     ; (handle-event sheet event)))
350    
351 mikemac 1.1 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
352 moore 1.9 (queue-event sheet event))
353 mikemac 1.1
354     (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
355     (with-slots (queue) sheet
356 gilbert 1.5 (event-queue-append queue event)))
357 brian 1.19
358     (defmethod schedule-event ((sheet standard-sheet-input-mixin) event delay)
359     (with-slots (queue) sheet
360 moore 1.21 (schedule-event-queue queue sheet event delay)))
361 mikemac 1.1
362     (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
363 moore 1.14 ;; Standard practice is to ignore events
364 mikemac 1.1 (declare (ignore event))
365     nil)
366    
367 hefner1 1.32 (defmethod event-read ((sheet standard-sheet-input-mixin))
368 mikemac 1.1 (with-slots (queue) sheet
369 gilbert 1.5 (event-queue-read queue)))
370 boninfan 1.3
371     (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
372     &key (timeout nil) (wait-function nil))
373 gilbert 1.5 ;; This one is not in the spec ;-( --GB
374 boninfan 1.3 (with-slots (queue) sheet
375 gilbert 1.13 (event-queue-read-with-timeout queue timeout wait-function)))
376 mikemac 1.1
377     (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
378     (with-slots (queue) sheet
379 gilbert 1.5 (event-queue-read-no-hang queue)))
380 mikemac 1.1
381     (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
382     (with-slots (queue) sheet
383     (if event-type
384 gilbert 1.5 (event-queue-peek-if (lambda (x)
385     (typep x event-type))
386     queue)
387     (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
388     queue))))
389 mikemac 1.1
390     (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
391     (with-slots (queue) sheet
392 gilbert 1.5 (event-queue-prepend queue event)))
393 mikemac 1.1
394 hefner1 1.32 (defmethod event-listen ((sheet standard-sheet-input-mixin))
395 mikemac 1.1 (with-slots (queue) sheet
396 gilbert 1.5 (event-queue-listen queue)))
397    
398     ;;;;
399 mikemac 1.1
400 moore 1.14 ;;; Support for callers that want to set an event queue for every pane.
401    
402     (defclass no-event-queue-mixin ()
403     ())
404    
405     (defmethod initialize-instance :after ((obj no-event-queue-mixin)
406     &key input-buffer)
407     (declare (ignore input-buffer))
408     nil)
409    
410     (defmethod (setf stream-input-buffer) (new-val (stream no-event-queue-mixin))
411     new-val)
412    
413     (defclass immediate-sheet-input-mixin (no-event-queue-mixin)
414 moore 1.9 ())
415 mikemac 1.1
416     (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
417     (handle-event sheet event))
418    
419 moore 1.11 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
420     (declare (ignore event))
421     nil)
422    
423 mikemac 1.1 (define-condition sheet-is-mute-for-input (error)
424 moore 1.14 ())
425 mikemac 1.1
426 moore 1.14 (defclass sheet-mute-input-mixin (no-event-queue-mixin)
427     ())
428 mikemac 1.1
429 rouanet 1.4 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
430 mikemac 1.1 (declare (ignore event))
431     (error 'sheet-is-mute-for-input))
432    
433 rouanet 1.4 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
434 mikemac 1.1 (declare (ignore event))
435     (error 'sheet-is-mute-for-input))
436    
437 brian 1.19 (defmethod schedule-event ((sheet sheet-mute-input-mixin) event delay)
438     (declare (ignore event delay))
439     (error 'sheet-is-mute-for-input))
440    
441 rouanet 1.4 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
442 mikemac 1.1 (declare (ignore event))
443     (error 'sheet-is-mute-for-input))
444    
445 rouanet 1.4 (defmethod event-read ((sheet sheet-mute-input-mixin))
446 mikemac 1.1 (error 'sheet-is-mute-for-input))
447    
448 rouanet 1.4 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
449 boninfan 1.3 &key (timeout nil) (wait-function nil))
450     (declare (ignore timeout wait-function))
451     (error 'sheet-is-mute-for-input))
452    
453 rouanet 1.4 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
454 mikemac 1.1 (error 'sheet-is-mute-for-input))
455    
456 rouanet 1.4 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
457 mikemac 1.1 (declare (ignore event-type))
458     (error 'sheet-is-mute-for-input))
459    
460 rouanet 1.4 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
461 mikemac 1.1 (declare (ignore event))
462     (error 'sheet-is-mute-for-input))
463    
464 rouanet 1.4 (defmethod event-listen ((sheet sheet-mute-input-mixin))
465 mikemac 1.1 (error 'sheet-is-mute-for-input))
466    
467 gilbert 1.5 ;;;;
468    
469 mikemac 1.1 (defclass delegate-sheet-input-mixin ()
470     ((delegate :initform nil
471     :initarg :delegate
472 gilbert 1.5 :accessor delegate-sheet-delegate) ))
473 moore 1.14
474     ;;; Don't know if this event queue stuff is completely right, or if it matters
475     ;;; much...
476    
477     (defmethod initialize-instance :after ((obj delegate-sheet-input-mixin)
478     &key input-buffer)
479     (declare (ignore input-buffer)))
480    
481     (defmethod stream-input-buffer ((stream delegate-sheet-input-mixin))
482     (sheet-event-queue (delegate-sheet-delegate stream)))
483    
484     (defmethod (setf stream-input-buffer) (new-val
485     (stream delegate-sheet-input-mixin))
486     (setf (stream-input-buffer (delegate-sheet-delegate stream)) new-val))
487 mikemac 1.1
488     (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
489     (dispatch-event (delegate-sheet-delegate sheet) event))
490    
491     (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
492     (queue-event (delegate-sheet-delegate sheet) event))
493 brian 1.19
494     (defmethod schedule-event ((sheet delegate-sheet-input-mixin) event delay)
495     (schedule-event (delegate-sheet-delegate sheet) event delay))
496 mikemac 1.1
497     (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
498     (handle-event (delegate-sheet-delegate sheet) event))
499    
500 hefner1 1.32 (defmethod event-read ((sheet delegate-sheet-input-mixin))
501 mikemac 1.1 (event-read (delegate-sheet-delegate sheet)))
502 boninfan 1.3
503     (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
504     &key (timeout nil) (wait-function nil))
505     (event-read-with-timeout (delegate-sheet-delegate sheet)
506     :timeout timeout :wait-function wait-function))
507 mikemac 1.1
508     (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
509     (event-read-no-hang (delegate-sheet-delegate sheet)))
510    
511     (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
512     (event-peek (delegate-sheet-delegate sheet) event-type))
513    
514     (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
515     (event-unread (delegate-sheet-delegate sheet) event))
516    
517     (defmethod event-listen ((sheet delegate-sheet-input-mixin))
518     (event-listen (delegate-sheet-delegate sheet)))
519 moore 1.9
520     ;;; Class actually used by panes.
521    
522 ahefner 1.36 (defclass clim-sheet-input-mixin (standard-sheet-input-mixin)
523 moore 1.9 ())

  ViewVC Help
Powered by ViewVC 1.1.5