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

Contents of /mcclim/input.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide 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 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     (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 mikemac 1.1 (defclass standard-sheet-input-mixin ()
87 gilbert 1.5 ((queue :initform (make-instance 'standard-event-queue))
88 mikemac 1.1 (port :initform nil
89     :initarg :port
90     :reader port)
91     ))
92    
93     (defmethod dispatch-event ((sheet standard-sheet-input-mixin) event)
94 cvs 1.2 (if (typep event 'device-event)
95     (queue-event sheet event)
96     (handle-event sheet event)))
97 mikemac 1.1
98 gilbert 1.6 (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 mikemac 1.1 (defmethod queue-event ((sheet standard-sheet-input-mixin) event)
105     (with-slots (queue) sheet
106 gilbert 1.5 (event-queue-append queue event)))
107 mikemac 1.1
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 gilbert 1.5 (event-queue-read queue)))
116 boninfan 1.3
117     (defmethod event-read-with-timeout ((sheet standard-sheet-input-mixin)
118     &key (timeout nil) (wait-function nil))
119 gilbert 1.5 ;; This one is not in the spec ;-( --GB
120 boninfan 1.3 (with-slots (queue) sheet
121 gilbert 1.5 (event-queue-read queue)))
122 mikemac 1.1
123     (defmethod event-read-no-hang ((sheet standard-sheet-input-mixin))
124     (with-slots (queue) sheet
125 gilbert 1.5 (event-queue-read-no-hang queue)))
126 mikemac 1.1
127     (defmethod event-peek ((sheet standard-sheet-input-mixin) &optional event-type)
128     (with-slots (queue) sheet
129     (if event-type
130 gilbert 1.5 (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 mikemac 1.1
136     (defmethod event-unread ((sheet standard-sheet-input-mixin) event)
137     (with-slots (queue) sheet
138 gilbert 1.5 (event-queue-prepend queue event)))
139 mikemac 1.1
140     (defmethod event-listen ((sheet standard-sheet-input-mixin))
141     (with-slots (queue) sheet
142 gilbert 1.5 (event-queue-listen queue)))
143    
144     ;;;;
145 mikemac 1.1
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 rouanet 1.4 (defclass sheet-mute-input-mixin ()
158 mikemac 1.1 (
159     ))
160    
161 rouanet 1.4 (defmethod dispatch-event ((sheet sheet-mute-input-mixin) event)
162 mikemac 1.1 (declare (ignore event))
163     (error 'sheet-is-mute-for-input))
164    
165 rouanet 1.4 (defmethod queue-event ((sheet sheet-mute-input-mixin) event)
166 mikemac 1.1 (declare (ignore event))
167     (error 'sheet-is-mute-for-input))
168    
169 rouanet 1.4 (defmethod handle-event ((sheet sheet-mute-input-mixin) event)
170 mikemac 1.1 (declare (ignore event))
171     (error 'sheet-is-mute-for-input))
172    
173 rouanet 1.4 (defmethod event-read ((sheet sheet-mute-input-mixin))
174 mikemac 1.1 (error 'sheet-is-mute-for-input))
175    
176 rouanet 1.4 (defmethod event-read-with-timeout ((sheet sheet-mute-input-mixin)
177 boninfan 1.3 &key (timeout nil) (wait-function nil))
178     (declare (ignore timeout wait-function))
179     (error 'sheet-is-mute-for-input))
180    
181 rouanet 1.4 (defmethod event-read-no-hang ((sheet sheet-mute-input-mixin))
182 mikemac 1.1 (error 'sheet-is-mute-for-input))
183    
184 rouanet 1.4 (defmethod event-peek ((sheet sheet-mute-input-mixin) &optional event-type)
185 mikemac 1.1 (declare (ignore event-type))
186     (error 'sheet-is-mute-for-input))
187    
188 rouanet 1.4 (defmethod event-unread ((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 event-listen ((sheet sheet-mute-input-mixin))
193 mikemac 1.1 (error 'sheet-is-mute-for-input))
194    
195 gilbert 1.5 ;;;;
196    
197 mikemac 1.1 (defclass delegate-sheet-input-mixin ()
198     ((delegate :initform nil
199     :initarg :delegate
200 gilbert 1.5 :accessor delegate-sheet-delegate) ))
201 mikemac 1.1
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 boninfan 1.3
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 mikemac 1.1
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