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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5