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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (show annotations)
Sat Feb 16 02:48:22 2002 UTC (12 years, 2 months ago) by gilbert
Branch: MAIN
Changes since 1.5: +6 -0 lines
Using two methods instead of IF now in DISPATCH-EVENT.
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-if (predicate (eq standard-event-queue))
75 "Goes thru the whole event queue an returns the first event, which
76 satisfies 'predicate' and leaves the event in the queue.
77 Returns NIL, if there is no such event."
78 (with-lock-held ((event-queue-lock eq))
79 (find-if predicate (event-queue-head eq))))
80
81 (defmethod event-queue-listen ((eq standard-event-queue))
82 (not (null (event-queue-head eq))))
83
84 ;; STANDARD-SHEET-INPUT-MIXIN
85
86 (defclass standard-sheet-input-mixin ()
87 ((queue :initform (make-instance 'standard-event-queue))
88 (port :initform nil
89 :initarg :port
90 :reader port)
91 ))
92
93 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
94 (if (typep event 'device-event)
95 (queue-event sheet event)
96 (handle-event sheet event)))
97
98 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) (event device-event))
99 (queue-event sheet event))
100
101 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
102 (handle-event sheet event))
103
104 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
105 (with-slots (queue) sheet
106 (event-queue-append queue event)))
107
108 (defmethod handle-event ((sheet standard-sheet-input-mixin) event)
109 ;; Standard practice is too ignore events
110 (declare (ignore event))
111 nil)
112
113 (defmethod event-read ((sheet standard-sheet-input-mixin))
114 (with-slots (queue) sheet
115 (event-queue-read queue)))
116
117 (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
118 &key (timeout nil) (wait-function nil))
119 ;; This one is not in the spec ;-( --GB
120 (with-slots (queue) sheet
121 (event-queue-read queue)))
122
123 (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
124 (with-slots (queue) sheet
125 (event-queue-read-no-hang queue)))
126
127 (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
128 (with-slots (queue) sheet
129 (if event-type
130 (event-queue-peek-if (lambda (x)
131 (typep x event-type))
132 queue)
133 (event-queue-peek-if (lambda (x) (declare (ignore x)) t)
134 queue))))
135
136 (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
137 (with-slots (queue) sheet
138 (event-queue-prepend queue event)))
139
140 (defmethod event-listen ((sheet standard-sheet-input-mixin))
141 (with-slots (queue) sheet
142 (event-queue-listen queue)))
143
144 ;;;;
145
146 (defclass immediate-sheet-input-mixin (standard-sheet-input-mixin)
147 (
148 ))
149
150 (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
151 (handle-event sheet event))
152
153 (define-condition sheet-is-mute-for-input (error)
154 (
155 ))
156
157 (defclass sheet-mute-input-mixin ()
158 (
159 ))
160
161 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
162 (declare (ignore event))
163 (error 'sheet-is-mute-for-input))
164
165 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
166 (declare (ignore event))
167 (error 'sheet-is-mute-for-input))
168
169 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
170 (declare (ignore event))
171 (error 'sheet-is-mute-for-input))
172
173 (defmethod event-read ((sheet sheet-mute-input-mixin))
174 (error 'sheet-is-mute-for-input))
175
176 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
177 &key (timeout nil) (wait-function nil))
178 (declare (ignore timeout wait-function))
179 (error 'sheet-is-mute-for-input))
180
181 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
182 (error 'sheet-is-mute-for-input))
183
184 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
185 (declare (ignore event-type))
186 (error 'sheet-is-mute-for-input))
187
188 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
189 (declare (ignore event))
190 (error 'sheet-is-mute-for-input))
191
192 (defmethod event-listen ((sheet sheet-mute-input-mixin))
193 (error 'sheet-is-mute-for-input))
194
195 ;;;;
196
197 (defclass delegate-sheet-input-mixin ()
198 ((delegate :initform nil
199 :initarg :delegate
200 :accessor delegate-sheet-delegate) ))
201
202 (defmethod dispatch-event ((sheet delegate-sheet-input-mixin) event)
203 (dispatch-event (delegate-sheet-delegate sheet) event))
204
205 (defmethod queue-event ((sheet delegate-sheet-input-mixin) event)
206 (queue-event (delegate-sheet-delegate sheet) event))
207
208 (defmethod handle-event ((sheet delegate-sheet-input-mixin) event)
209 (handle-event (delegate-sheet-delegate sheet) event))
210
211 (defmethod event-read ((sheet delegate-sheet-input-mixin))
212 (event-read (delegate-sheet-delegate sheet)))
213
214 (defmethod event-read-with-timeout ((sheet delegate-sheet-input-mixin)
215 &key (timeout nil) (wait-function nil))
216 (event-read-with-timeout (delegate-sheet-delegate sheet)
217 :timeout timeout :wait-function wait-function))
218
219 (defmethod event-read-no-hang ((sheet delegate-sheet-input-mixin))
220 (event-read-no-hang (delegate-sheet-delegate sheet)))
221
222 (defmethod event-peek ((sheet delegate-sheet-input-mixin) &optional event-type)
223 (event-peek (delegate-sheet-delegate sheet) event-type))
224
225 (defmethod event-unread ((sheet delegate-sheet-input-mixin) event)
226 (event-unread (delegate-sheet-delegate sheet) event))
227
228 (defmethod event-listen ((sheet delegate-sheet-input-mixin))
229 (event-listen (delegate-sheet-delegate sheet)))
230

  ViewVC Help
Powered by ViewVC 1.1.5