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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.39 - (hide 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 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 dlichteblau 1.39 (unless (condition-wait (event-queue-processes eq) lock timeout)
101     (return)))))))
102 gilbert 1.13
103 gilbert 1.5 (defmethod event-queue-append ((eq standard-event-queue) item)
104 gilbert 1.15 "Append the item at the end of the queue. Does event compression."
105 gilbert 1.5 (with-lock-held ((event-queue-lock eq))
106 hefner1 1.23 (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 gilbert 1.15 ;; 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 hefner1 1.23 (setf (event-queue-head eq) (fun (event-queue-head eq))))))
194 gilbert 1.15 ;; Regular events are just appended:
195 moore 1.29 (t (append-event))))
196     (condition-notify (event-queue-processes eq))))
197 gilbert 1.5
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 moore 1.29 (push item (event-queue-head eq))))
206     (condition-notify (event-queue-processes eq))))
207 gilbert 1.5
208 mikemac 1.7 (defmethod event-queue-peek ((eq standard-event-queue))
209     (with-lock-held ((event-queue-lock eq))
210 brian 1.19 (check-schedule eq)
211 mikemac 1.7 (first (event-queue-head eq))))
212    
213 gilbert 1.5 (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
214 gilbert 1.15 "Goes thru the whole event queue and returns the first event, which
215 gilbert 1.5 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 brian 1.19 (check-schedule eq)
222 gilbert 1.5 (not (null (event-queue-head eq))))
223    
224 brian 1.19 (defun now ()
225     (/ (get-internal-real-time)
226     internal-time-units-per-second))
227    
228 moore 1.8 (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)
229 brian 1.19 (check-schedule eq)
230 moore 1.29 (let ((lock (event-queue-lock eq)))
231     (with-lock-held (lock)
232 tmoore 1.33 (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 moore 1.29 (condition-wait (event-queue-processes eq) lock)
260     t)))))))))
261 brian 1.19
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 moore 1.21 (defmethod schedule-event-queue ((eq standard-event-queue) sheet event delay)
275 brian 1.19 (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 gilbert 1.24 ; (format *trace-output* "queue = ~A~%" schedule)
286 brian 1.19 (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 moore 1.8
298 hefner1 1.25 ;; PORT-EVENT-QUEUE methods
299    
300 hefner1 1.27 (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 hefner1 1.25 (defmethod event-queue-read :before ((eq port-event-queue))
305 hefner1 1.27 (do-port-force-output eq))
306 hefner1 1.25
307     (defmethod event-queue-read-no-hang :before ((eq port-event-queue))
308 hefner1 1.27 (do-port-force-output eq))
309 hefner1 1.25
310     (defmethod event-queue-read-with-timeout :before ((eq port-event-queue)
311     timeout wait-function)
312     (declare (ignore timeout wait-function))
313 hefner1 1.27 (do-port-force-output eq))
314 hefner1 1.25
315     (defmethod event-queue-listen :before ((eq port-event-queue))
316 hefner1 1.27 (do-port-force-output eq))
317 hefner1 1.25
318     (defmethod event-queue-listen-or-wait :before ((eq standard-event-queue)
319     &key timeout)
320     (declare (ignore timeout))
321 hefner1 1.27 (do-port-force-output eq))
322 hefner1 1.25
323     (defmethod event-queue-peek :before ((eq port-event-queue))
324 hefner1 1.27 (do-port-force-output eq))
325 hefner1 1.25
326     (defmethod event-queue-peek-if :before (predicate (eq port-event-queue))
327     (declare (ignore predicate))
328 hefner1 1.27 (do-port-force-output eq))
329 hefner1 1.25
330 gilbert 1.5 ;; STANDARD-SHEET-INPUT-MIXIN
331    
332 mikemac 1.1 (defclass standard-sheet-input-mixin ()
333 hefner1 1.25 ((queue :initform (make-instance 'port-event-queue)
334 moore 1.14 :reader sheet-event-queue
335     :initarg :input-buffer)
336 mikemac 1.1 (port :initform nil
337     :initarg :port
338 moore 1.14 :reader port)))
339 hefner1 1.25
340 mikemac 1.7 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
341     (sheet-event-queue stream))
342    
343 moore 1.14 (defmethod (setf stream-input-buffer) (new-val
344     (stream standard-sheet-input-mixin))
345     (setf (slot-value stream 'queue) new-val))
346    
347 mikemac 1.7 ;(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 mikemac 1.1 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
353 moore 1.9 (queue-event sheet event))
354 mikemac 1.1
355     (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
356     (with-slots (queue) sheet
357 gilbert 1.5 (event-queue-append queue event)))
358 brian 1.19
359     (defmethod schedule-event ((sheet standard-sheet-input-mixin) event delay)
360     (with-slots (queue) sheet
361 moore 1.21 (schedule-event-queue queue sheet event delay)))
362 mikemac 1.1
363     (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
364 moore 1.14 ;; Standard practice is to ignore events
365 mikemac 1.1 (declare (ignore event))
366     nil)
367    
368 hefner1 1.32 (defmethod event-read ((sheet standard-sheet-input-mixin))
369 mikemac 1.1 (with-slots (queue) sheet
370 gilbert 1.5 (event-queue-read queue)))
371 boninfan 1.3
372     (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
373     &key (timeout nil) (wait-function nil))
374 gilbert 1.5 ;; This one is not in the spec ;-( --GB
375 boninfan 1.3 (with-slots (queue) sheet
376 gilbert 1.13 (event-queue-read-with-timeout queue timeout wait-function)))
377 mikemac 1.1
378     (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
379     (with-slots (queue) sheet
380 gilbert 1.5 (event-queue-read-no-hang queue)))
381 mikemac 1.1
382     (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
383     (with-slots (queue) sheet
384     (if event-type
385 gilbert 1.5 (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 mikemac 1.1
391     (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
392     (with-slots (queue) sheet
393 gilbert 1.5 (event-queue-prepend queue event)))
394 mikemac 1.1
395 hefner1 1.32 (defmethod event-listen ((sheet standard-sheet-input-mixin))
396 mikemac 1.1 (with-slots (queue) sheet
397 gilbert 1.5 (event-queue-listen queue)))
398    
399     ;;;;
400 mikemac 1.1
401 moore 1.14 ;;; 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 moore 1.9 ())
416 mikemac 1.1
417     (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
418     (handle-event sheet event))
419    
420 moore 1.11 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
421     (declare (ignore event))
422     nil)
423    
424 mikemac 1.1 (define-condition sheet-is-mute-for-input (error)
425 moore 1.14 ())
426 mikemac 1.1
427 moore 1.14 (defclass sheet-mute-input-mixin (no-event-queue-mixin)
428     ())
429 mikemac 1.1
430 rouanet 1.4 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
431 mikemac 1.1 (declare (ignore event))
432     (error 'sheet-is-mute-for-input))
433    
434 rouanet 1.4 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
435 mikemac 1.1 (declare (ignore event))
436     (error 'sheet-is-mute-for-input))
437    
438 brian 1.19 (defmethod schedule-event ((sheet sheet-mute-input-mixin) event delay)
439     (declare (ignore event delay))
440     (error 'sheet-is-mute-for-input))
441    
442 rouanet 1.4 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
443 mikemac 1.1 (declare (ignore event))
444     (error 'sheet-is-mute-for-input))
445    
446 rouanet 1.4 (defmethod event-read ((sheet sheet-mute-input-mixin))
447 mikemac 1.1 (error 'sheet-is-mute-for-input))
448    
449 rouanet 1.4 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
450 boninfan 1.3 &key (timeout nil) (wait-function nil))
451     (declare (ignore timeout wait-function))
452     (error 'sheet-is-mute-for-input))
453    
454 rouanet 1.4 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
455 mikemac 1.1 (error 'sheet-is-mute-for-input))
456    
457 rouanet 1.4 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
458 mikemac 1.1 (declare (ignore event-type))
459     (error 'sheet-is-mute-for-input))
460    
461 rouanet 1.4 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
462 mikemac 1.1 (declare (ignore event))
463     (error 'sheet-is-mute-for-input))
464    
465 rouanet 1.4 (defmethod event-listen ((sheet sheet-mute-input-mixin))
466 mikemac 1.1 (error 'sheet-is-mute-for-input))
467    
468 gilbert 1.5 ;;;;
469    
470 mikemac 1.1 (defclass delegate-sheet-input-mixin ()
471     ((delegate :initform nil
472     :initarg :delegate
473 gilbert 1.5 :accessor delegate-sheet-delegate) ))
474 moore 1.14
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 mikemac 1.1
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 brian 1.19
495     (defmethod schedule-event ((sheet delegate-sheet-input-mixin) event delay)
496     (schedule-event (delegate-sheet-delegate sheet) event delay))
497 mikemac 1.1
498     (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
499     (handle-event (delegate-sheet-delegate sheet) event))
500    
501 hefner1 1.32 (defmethod event-read ((sheet delegate-sheet-input-mixin))
502 mikemac 1.1 (event-read (delegate-sheet-delegate sheet)))
503 boninfan 1.3
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 mikemac 1.1
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 moore 1.9
521     ;;; Class actually used by panes.
522    
523 ahefner 1.36 (defclass clim-sheet-input-mixin (standard-sheet-input-mixin)
524 moore 1.9 ())

  ViewVC Help
Powered by ViewVC 1.1.5