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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (hide annotations)
Tue Apr 23 01:50:00 2002 UTC (12 years 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 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     (in-package :CLIM-INTERNALS)
22    
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     :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 brian 1.10 (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 gilbert 1.5
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 mikemac 1.7 (defmethod event-queue-peek ((eq standard-event-queue))
82     (with-lock-held ((event-queue-lock eq))
83     (first (event-queue-head eq))))
84    
85 gilbert 1.5 (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 moore 1.8 (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 gilbert 1.5 ;; STANDARD-SHEET-INPUT-MIXIN
105    
106 mikemac 1.1 (defclass standard-sheet-input-mixin ()
107 mikemac 1.7 ((queue :initform (make-instance 'standard-event-queue)
108     :reader sheet-event-queue)
109 mikemac 1.1 (port :initform nil
110     :initarg :port
111     :reader port)
112     ))
113    
114 mikemac 1.7 (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 mikemac 1.1 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
123 moore 1.9 (queue-event sheet event))
124 mikemac 1.1
125 gilbert 1.6 (defmethod dispatch-event ((sheet standard-sheet-input-mixin) (event device-event))
126     (queue-event sheet event))
127    
128 mikemac 1.1 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
129     (with-slots (queue) sheet
130 gilbert 1.5 (event-queue-append queue event)))
131 mikemac 1.1
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 gilbert 1.5 (event-queue-read queue)))
140 boninfan 1.3
141     (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
142     &key (timeout nil) (wait-function nil))
143 gilbert 1.5 ;; This one is not in the spec ;-( --GB
144 boninfan 1.3 (with-slots (queue) sheet
145 gilbert 1.5 (event-queue-read queue)))
146 mikemac 1.1
147     (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
148     (with-slots (queue) sheet
149 gilbert 1.5 (event-queue-read-no-hang queue)))
150 mikemac 1.1
151     (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
152     (with-slots (queue) sheet
153     (if event-type
154 gilbert 1.5 (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 mikemac 1.1
160     (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
161     (with-slots (queue) sheet
162 gilbert 1.5 (event-queue-prepend queue event)))
163 mikemac 1.1
164     (defmethod event-listen ((sheet standard-sheet-input-mixin))
165     (with-slots (queue) sheet
166 gilbert 1.5 (event-queue-listen queue)))
167    
168     ;;;;
169 mikemac 1.1
170 moore 1.9 (defclass immediate-sheet-input-mixin ()
171     ())
172 mikemac 1.1
173     (defmethod dispatch-event ((sheet immediate-sheet-input-mixin) event)
174     (handle-event sheet event))
175    
176 moore 1.11 (defmethod handle-event ((sheet immediate-sheet-input-mixin) event)
177     (declare (ignore event))
178     nil)
179    
180 mikemac 1.1 (define-condition sheet-is-mute-for-input (error)
181     (
182     ))
183    
184 rouanet 1.4 (defclass sheet-mute-input-mixin ()
185 mikemac 1.1 (
186     ))
187    
188 rouanet 1.4 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
189 mikemac 1.1 (declare (ignore event))
190     (error 'sheet-is-mute-for-input))
191    
192 rouanet 1.4 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
193 mikemac 1.1 (declare (ignore event))
194     (error 'sheet-is-mute-for-input))
195    
196 rouanet 1.4 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
197 mikemac 1.1 (declare (ignore event))
198     (error 'sheet-is-mute-for-input))
199    
200 rouanet 1.4 (defmethod event-read ((sheet sheet-mute-input-mixin))
201 mikemac 1.1 (error 'sheet-is-mute-for-input))
202    
203 rouanet 1.4 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
204 boninfan 1.3 &key (timeout nil) (wait-function nil))
205     (declare (ignore timeout wait-function))
206     (error 'sheet-is-mute-for-input))
207    
208 rouanet 1.4 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
209 mikemac 1.1 (error 'sheet-is-mute-for-input))
210    
211 rouanet 1.4 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
212 mikemac 1.1 (declare (ignore event-type))
213     (error 'sheet-is-mute-for-input))
214    
215 rouanet 1.4 (defmethod event-unread ((sheet sheet-mute-input-mixin) event)
216 mikemac 1.1 (declare (ignore event))
217     (error 'sheet-is-mute-for-input))
218    
219 rouanet 1.4 (defmethod event-listen ((sheet sheet-mute-input-mixin))
220 mikemac 1.1 (error 'sheet-is-mute-for-input))
221    
222 gilbert 1.5 ;;;;
223    
224 mikemac 1.1 (defclass delegate-sheet-input-mixin ()
225     ((delegate :initform nil
226     :initarg :delegate
227 gilbert 1.5 :accessor delegate-sheet-delegate) ))
228 mikemac 1.1
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 boninfan 1.3
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 mikemac 1.1
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 moore 1.9
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 mikemac 1.1

  ViewVC Help
Powered by ViewVC 1.1.5