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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (show annotations)
Tue Apr 23 01:50:00 2002 UTC (11 years, 11 months ago) by moore
Branch: MAIN
Changes since 1.10: +4 -0 lines
Supply null handle-event for immediate-sheet-input-mixin.  This should
fix Brian's problems.

Add a couple of text-style trampolines for sheets.

Add an eval-when around with-presentation-types-decoded to satisfy
ACL.

Add a new macro, clim-defsystem, that does the right thing whether
using mk:defsystem or not.  Add a :clim-frontend target which is the
same as the old :clim target; :clim now forces :clim-clx to load.

Various fixes on the road to getting Goatee working.
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 (if *multiprocessing-p*
52 (process-wait "Waiting for event"
53 (lambda ()
54 (not (null (event-queue-head eq)))))
55 (process-wait "Waiting for event"
56 (lambda ()
57 (loop for port in climi::*all-ports*
58 ; this is dubious
59 do (process-next-event port))
60 (not (null (event-queue-head eq)))))))))
61
62 (defmethod event-queue-append ((eq standard-event-queue) item)
63 "Append the item at the end of the queue."
64 (with-lock-held ((event-queue-lock eq))
65 (cond ((null (event-queue-tail eq))
66 (setf (event-queue-head eq) (cons item nil)
67 (event-queue-tail eq) (event-queue-head eq)))
68 (t
69 (setf (event-queue-tail eq)
70 (setf (cdr (event-queue-tail eq)) (cons item nil)))))))
71
72 (defmethod event-queue-prepend ((eq standard-event-queue) item)
73 "Prepend the item to the beginning of the queue."
74 (with-lock-held ((event-queue-lock eq))
75 (cond ((null (event-queue-tail eq))
76 (setf (event-queue-head eq) (cons item nil)
77 (event-queue-tail eq) (event-queue-head eq)))
78 (t
79 (push item (event-queue-head eq))))))
80
81 (defmethod event-queue-peek ((eq standard-event-queue))
82 (with-lock-held ((event-queue-lock eq))
83 (first (event-queue-head eq))))
84
85 (defmethod event-queue-peek-if (predicate (eq standard-event-queue))
86 "Goes thru the whole event queue an returns the first event, which
87 satisfies 'predicate' and leaves the event in the queue.
88 Returns NIL, if there is no such event."
89 (with-lock-held ((event-queue-lock eq))
90 (find-if predicate (event-queue-head eq))))
91
92 (defmethod event-queue-listen ((eq standard-event-queue))
93 (not (null (event-queue-head eq))))
94
95 (defmethod event-queue-listen-or-wait ((eq standard-event-queue) &key timeout)
96 (or (not (null (event-queue-peek eq)))
97 (flet ((pred ()
98 (not (null (event-queue-head eq)))))
99 (if timeout
100 (process-wait-with-timeout "Listening for event" timeout #'pred)
101 (process-wait "Listening for event" #'pred)))))
102
103
104 ;; STANDARD-SHEET-INPUT-MIXIN
105
106 (defclass standard-sheet-input-mixin ()
107 ((queue :initform (make-instance 'standard-event-queue)
108 :reader sheet-event-queue)
109 (port :initform nil
110 :initarg :port
111 :reader port)
112 ))
113
114 (defmethod stream-input-buffer ((stream standard-sheet-input-mixin))
115 (sheet-event-queue stream))
116
117 ;(defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
118 ; (if (typep event 'device-event)
119 ; (queue-event sheet event)
120 ; (handle-event sheet event)))
121
122 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
123 (queue-event sheet event))
124
125 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) (event device-event))
126 (queue-event sheet event))
127
128 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
129 (with-slots (queue) sheet
130 (event-queue-append queue event)))
131
132 (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
133 ;; Standard practice is too ignore events
134 (declare (ignore event))
135 nil)
136
137 (defmethod event-read ((sheet standard-sheet-input-mixin))
138 (with-slots (queue) sheet
139 (event-queue-read queue)))
140
141 (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
142 &key (timeout nil) (wait-function nil))
143 ;; This one is not in the spec ;-( --GB
144 (with-slots (queue) sheet
145 (event-queue-read queue)))
146
147 (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
148 (with-slots (queue) sheet
149 (event-queue-read-no-hang queue)))
150
151 (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
152 (with-slots (queue) sheet
153 (if event-type
154 (event-queue-peek-if (lambda (x)
155 (typep x event-type))
156 queue)
157 (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
158 queue))))
159
160 (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
161 (with-slots (queue) sheet
162 (event-queue-prepend queue event)))
163
164 (defmethod event-listen ((sheet standard-sheet-input-mixin))
165 (with-slots (queue) sheet
166 (event-queue-listen queue)))
167
168 ;;;;
169
170 (defclass immediate-sheet-input-mixin ()
171 ())
172
173 (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
174 (handle-event sheet event))
175
176 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
177 (declare (ignore event))
178 nil)
179
180 (define-condition sheet-is-mute-for-input (error)
181 (
182 ))
183
184 (defclass sheet-mute-input-mixin ()
185 (
186 ))
187
188 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
189 (declare (ignore event))
190 (error 'sheet-is-mute-for-input))
191
192 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
193 (declare (ignore event))
194 (error 'sheet-is-mute-for-input))
195
196 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
197 (declare (ignore event))
198 (error 'sheet-is-mute-for-input))
199
200 (defmethod event-read ((sheet sheet-mute-input-mixin))
201 (error 'sheet-is-mute-for-input))
202
203 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
204 &key (timeout nil) (wait-function nil))
205 (declare (ignore timeout wait-function))
206 (error 'sheet-is-mute-for-input))
207
208 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
209 (error 'sheet-is-mute-for-input))
210
211 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
212 (declare (ignore event-type))
213 (error 'sheet-is-mute-for-input))
214
215 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
216 (declare (ignore event))
217 (error 'sheet-is-mute-for-input))
218
219 (defmethod event-listen ((sheet sheet-mute-input-mixin))
220 (error 'sheet-is-mute-for-input))
221
222 ;;;;
223
224 (defclass delegate-sheet-input-mixin ()
225 ((delegate :initform nil
226 :initarg :delegate
227 :accessor delegate-sheet-delegate) ))
228
229 (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
230 (dispatch-event (delegate-sheet-delegate sheet) event))
231
232 (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
233 (queue-event (delegate-sheet-delegate sheet) event))
234
235 (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
236 (handle-event (delegate-sheet-delegate sheet) event))
237
238 (defmethod event-read ((sheet delegate-sheet-input-mixin))
239 (event-read (delegate-sheet-delegate sheet)))
240
241 (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
242 &key (timeout nil) (wait-function nil))
243 (event-read-with-timeout (delegate-sheet-delegate sheet)
244 :timeout timeout :wait-function wait-function))
245
246 (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
247 (event-read-no-hang (delegate-sheet-delegate sheet)))
248
249 (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
250 (event-peek (delegate-sheet-delegate sheet) event-type))
251
252 (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
253 (event-unread (delegate-sheet-delegate sheet) event))
254
255 (defmethod event-listen ((sheet delegate-sheet-input-mixin))
256 (event-listen (delegate-sheet-delegate sheet)))
257
258 ;;; Class actually used by panes.
259
260 (defclass clim-sheet-input-mixin (#+clim-mp standard-sheet-input-mixin #-clim-mp immediate-sheet-input-mixin)
261 ())
262
263 ;;; Utility for handling all the events on queues of child sheets
264
265 (defun handle-events-over-sheets (sheet exclude)
266 "Utility for handling all the events on queues of child sheets. The
267 EXCLUDE argument is either nil, a sheet or a list of sheets to
268 ignore. This avoids various race conditions in event processing."
269 (flet ((handler (s)
270 (when (and exclude
271 (or (and (consp exclude)
272 (member s exclude :test #'eq))
273 (eq exclude s)))
274 (return-from handler nil))
275 (when (typep s 'standard-sheet-input-mixin)
276 (loop for event = (event-read-no-hang s)
277 while event
278 do (handle-event s event)))))
279 (declare (dynamic-extent handler))
280 (map-over-sheets #'handler sheet)))
281

  ViewVC Help
Powered by ViewVC 1.1.5