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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Tue Mar 12 21:05:06 2002 UTC (12 years, 1 month ago) by moore
Branch: MAIN
Changes since 1.7: +9 -0 lines
Checkin to get context sensitive input working with multi-threaded
process-next-event.

Set input focus in run-frame-top-level.  Assume that someday, in the
presence of multiple frames, we'll do the right thing with switching
the input focus from frame to frame.

Added a frame-intercept-event-queue to frames.  process-next-event
examines the frame associated with the pane that has input focus and
puts device events on that frame's queue if desired.

Rewrote stream-input-wait, stream-read-gesture and the
with-input-context input-test and input-handler functions per
mikemac's suggestions.  The with-input-context stuff uses the
intercept queue mechanism now.

Fixed a typo in gadgets.lisp.
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
37 (defmethod event-queue-read-no-hang ((eq standard-event-queue))
38 "Reads one event from the queue, if there is no event just return NIL."
39 (with-lock-held ((event-queue-lock eq))
40 (let ((res (pop (event-queue-head eq))))
41 (when (null (event-queue-head eq))
42 (setf (event-queue-tail eq) nil))
43 res)))
44
45 (defmethod event-queue-read ((eq standard-event-queue))
46 "Reads one event from the queue, if there is no event, hang until here is one."
47 (loop
48 (let ((res (event-queue-read-no-hang eq)))
49 (when res
50 (return res))
51 (process-wait "Waiting for event"
52 (lambda ()
53 (not (null (event-queue-head eq))))))))
54
55 (defmethod event-queue-append ((eq standard-event-queue) item)
56 "Append the item at the end of the queue."
57 (with-lock-held ((event-queue-lock eq))
58 (cond ((null (event-queue-tail eq))
59 (setf (event-queue-head eq) (cons item nil)
60 (event-queue-tail eq) (event-queue-head eq)))
61 (t
62 (setf (event-queue-tail eq)
63 (setf (cdr (event-queue-tail eq)) (cons item nil)))))))
64
65 (defmethod event-queue-prepend ((eq standard-event-queue) item)
66 "Prepend the item to the beginning of the queue."
67 (with-lock-held ((event-queue-lock eq))
68 (cond ((null (event-queue-tail eq))
69 (setf (event-queue-head eq) (cons item nil)
70 (event-queue-tail eq) (event-queue-head eq)))
71 (t
72 (push item (event-queue-head eq))))))
73
74 (defmethod event-queue-peek ((eq standard-event-queue))
75 (with-lock-held ((event-queue-lock eq))
76 (first (event-queue-head eq))))
77
78 (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
79 "Goes thru the whole event queue an returns the first event, which
80 satisfies 'predicate' and leaves the event in the queue.
81 Returns NIL, if there is no such event."
82 (with-lock-held ((event-queue-lock eq))
83 (find-if predicate (event-queue-head eq))))
84
85 (defmethod event-queue-listen ((eq standard-event-queue))
86 (not (null (event-queue-head eq))))
87
88 (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)
89 (or (not (null (event-queue-peek eq)))
90 (flet ((pred ()
91 (not (null (event-queue-head eq)))))
92 (if timeout
93 (process-wait-with-timeout "Listening for event" timeout #'pred)
94 (process-wait "Listening for event" #'pred)))))
95
96
97 ;; STANDARD-SHEET-INPUT-MIXIN
98
99 (defclass standard-sheet-input-mixin ()
100 ((queue :initform (make-instance 'standard-event-queue)
101 :reader sheet-event-queue)
102 (port :initform nil
103 :initarg :port
104 :reader port)
105 ))
106
107 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
108 (sheet-event-queue stream))
109
110 ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
111 ; (if (typep event 'device-event)
112 ; (queue-event sheet event)
113 ; (handle-event sheet event)))
114
115 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
116 (handle-event sheet event))
117
118 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) (event device-event))
119 (queue-event sheet event))
120
121 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
122 (with-slots (queue) sheet
123 (event-queue-append queue event)))
124
125 (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
126 ;; Standard practice is too ignore events
127 (declare (ignore event))
128 nil)
129
130 (defmethod event-read ((sheet standard-sheet-input-mixin))
131 (with-slots (queue) sheet
132 (event-queue-read queue)))
133
134 (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
135 &key (timeout nil) (wait-function nil))
136 ;; This one is not in the spec ;-( --GB
137 (with-slots (queue) sheet
138 (event-queue-read queue)))
139
140 (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
141 (with-slots (queue) sheet
142 (event-queue-read-no-hang queue)))
143
144 (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
145 (with-slots (queue) sheet
146 (if event-type
147 (event-queue-peek-if (lambda (x)
148 (typep x event-type))
149 queue)
150 (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
151 queue))))
152
153 (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
154 (with-slots (queue) sheet
155 (event-queue-prepend queue event)))
156
157 (defmethod event-listen ((sheet standard-sheet-input-mixin))
158 (with-slots (queue) sheet
159 (event-queue-listen queue)))
160
161 ;;;;
162
163 (defclass immediate-sheet-input-mixin (standard-sheet-input-mixin)
164 (
165 ))
166
167 (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
168 (handle-event sheet event))
169
170 (define-condition sheet-is-mute-for-input (error)
171 (
172 ))
173
174 (defclass sheet-mute-input-mixin ()
175 (
176 ))
177
178 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
179 (declare (ignore event))
180 (error 'sheet-is-mute-for-input))
181
182 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
183 (declare (ignore event))
184 (error 'sheet-is-mute-for-input))
185
186 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
187 (declare (ignore event))
188 (error 'sheet-is-mute-for-input))
189
190 (defmethod event-read ((sheet sheet-mute-input-mixin))
191 (error 'sheet-is-mute-for-input))
192
193 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
194 &key (timeout nil) (wait-function nil))
195 (declare (ignore timeout wait-function))
196 (error 'sheet-is-mute-for-input))
197
198 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
199 (error 'sheet-is-mute-for-input))
200
201 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
202 (declare (ignore event-type))
203 (error 'sheet-is-mute-for-input))
204
205 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
206 (declare (ignore event))
207 (error 'sheet-is-mute-for-input))
208
209 (defmethod event-listen ((sheet sheet-mute-input-mixin))
210 (error 'sheet-is-mute-for-input))
211
212 ;;;;
213
214 (defclass delegate-sheet-input-mixin ()
215 ((delegate :initform nil
216 :initarg :delegate
217 :accessor delegate-sheet-delegate) ))
218
219 (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
220 (dispatch-event (delegate-sheet-delegate sheet) event))
221
222 (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
223 (queue-event (delegate-sheet-delegate sheet) event))
224
225 (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
226 (handle-event (delegate-sheet-delegate sheet) event))
227
228 (defmethod event-read ((sheet delegate-sheet-input-mixin))
229 (event-read (delegate-sheet-delegate sheet)))
230
231 (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
232 &key (timeout nil) (wait-function nil))
233 (event-read-with-timeout (delegate-sheet-delegate sheet)
234 :timeout timeout :wait-function wait-function))
235
236 (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
237 (event-read-no-hang (delegate-sheet-delegate sheet)))
238
239 (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
240 (event-peek (delegate-sheet-delegate sheet) event-type))
241
242 (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
243 (event-unread (delegate-sheet-delegate sheet) event))
244
245 (defmethod event-listen ((sheet delegate-sheet-input-mixin))
246 (event-listen (delegate-sheet-delegate sheet)))
247

  ViewVC Help
Powered by ViewVC 1.1.5