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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.35 - (show annotations)
Thu Aug 8 07:44:18 2002 UTC (11 years, 8 months ago) by moore
Branch: MAIN
Changes since 1.34: +2 -3 lines
Handle key events for modifier keys in order to keep track of modifier
state.  Implement keyboard-event-character.  Store coordinates of
pointer in key events.  Don't set the sheet of key events to the sheet
with focus.

The wait test and input handler functions now respond to key events.
The frame pointer documentation functions react if the modifier state
has changed.

Make a little protocol out of the pointer documentation update
operation.

Fix typo: too many n's in find-innnermost-presentation-context.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4 ;;; (c) copyright 2000 by
5 ;;; Iban Hatchondo (hatchond@emi.u-bordeaux.fr)
6 ;;; Julien Boninfante (boninfan@emi.u-bordeaux.fr)
7 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
8
9 ;;; This library is free software; you can redistribute it and/or
10 ;;; modify it under the terms of the GNU Library General Public
11 ;;; License as published by the Free Software Foundation; either
12 ;;; version 2 of the License, or (at your option) any later version.
13 ;;;
14 ;;; This library is distributed in the hope that it will be useful,
15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 ;;; Library General Public License for more details.
18 ;;;
19 ;;; You should have received a copy of the GNU Library General Public
20 ;;; License along with this library; if not, write to the
21 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;;; Boston, MA 02111-1307 USA.
23
24 (in-package :CLIM-INTERNALS)
25
26 (defvar *default-server-path* NIL)
27
28 (defvar *server-path-search-order* '(:genera :ms-windows :gtk :clx :x11 :opengl))
29
30 (defun find-default-server-path ()
31 (loop for port in *server-path-search-order*
32 if (get port :port-type)
33 do (return-from find-default-server-path (list port))
34 finally (error "No CLIM backends have been loaded!")))
35
36 (defvar *all-ports* nil)
37
38 (defclass port ()
39 ()
40 (:documentation
41 "The protocol class that corresponds to a port."))
42
43 (defclass basic-port (port)
44 ((server-path :initform nil
45 :initarg :server-path
46 :reader port-server-path)
47 (properties :initform nil
48 :initarg :properties)
49 (grafts :initform nil
50 :accessor port-grafts)
51 (frame-managers :initform nil
52 :reader frame-managers)
53 (sheet->mirror :initform (make-hash-table :test #'eq))
54 (mirror->sheet :initform (make-hash-table :test #'eq))
55 (pixmap->mirror :initform (make-hash-table :test #'eq))
56 (mirror->pixmap :initform (make-hash-table :test #'eq))
57 (keyboard-input-focus :initform nil
58 :initarg :keyboard-input-focus
59 :accessor port-keyboard-input-focus)
60 (event-process
61 :initform nil
62 :initarg :event-process
63 :accessor port-event-process
64 :documentation "In a multiprocessing environment, the particular process
65 reponsible for calling PROCESS-NEXT-EVENT in a loop.")
66
67 (lock
68 :initform (make-recursive-lock "port lock")
69 :accessor port-lock)
70 (event-count :initform 0)
71 (text-style-mappings :initform (make-hash-table :test #'eq)
72 :reader port-text-style-mappings)
73 ))
74
75 (defun find-port (&key (server-path *default-server-path*))
76 (if (null server-path)
77 (setq server-path (find-default-server-path)))
78 (if (atom server-path)
79 (setq server-path (list server-path)))
80 (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
81 (loop for port in *all-ports*
82 if (equal server-path (port-server-path port))
83 do (return port)
84 finally (let ((port-type (get (first server-path) :port-type))
85 port)
86 (if (null port-type)
87 (error "Don't know how to make a port of type ~S" server-path))
88 (setq port (funcall 'make-instance port-type :server-path server-path))
89 (push port *all-ports*)
90 (return port))))
91
92 (defmethod initialize-instance :after ((port basic-port) &rest args)
93 (declare (ignorable args))
94 )
95
96 (defmethod destroy-port :before ((port basic-port))
97 (when (and *multiprocessing-p* (port-event-process port))
98 (destroy-process (port-event-process port))
99 (setf (port-event-process port) nil)))
100
101 (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
102 (gethash sheet (slot-value port 'sheet->mirror)))
103
104 (defmethod port-lookup-sheet ((port basic-port) mirror)
105 (gethash mirror (slot-value port 'mirror->sheet)))
106
107 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
108 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
109 (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
110 nil)
111
112 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
113 (remhash sheet (slot-value port 'sheet->mirror))
114 (remhash mirror (slot-value port 'mirror->sheet))
115 nil)
116
117 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
118 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
119
120 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
121 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
122
123 (defmethod mirror-transformation ((port basic-port) mirror)
124 (declare (ignore mirror))
125 (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
126
127 (defmethod port-properties ((port basic-port) indicator)
128 (with-slots (properties) port
129 (getf properties indicator)))
130
131 (defmethod (setf port-properties) (value (port basic-port) indicator)
132 (with-slots (properties) port
133 (setf (getf properties indicator) value)))
134
135 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
136 (declare (ignore wait-function timeout))
137 (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
138
139 (defmethod get-next-event :after ((port basic-port) &key wait-function timeout)
140 (declare (ignore wait-function timeout))
141 (with-slots (event-count) port
142 (incf event-count)))
143
144 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
145 (let ((event (get-next-event port
146 :wait-function wait-function
147 :timeout timeout)))
148 (cond
149 ((null event) nil)
150 ((eq event :timeout) (values nil :timeout))
151 (t
152 (distribute-event port event)
153 t))))
154
155 ;;; Called in the application frame process.
156 (defmethod port-wait-on-event-processing ((port basic-port) &key wait-function timeout
157 ((:event-count old-count) nil))
158 (declare (ignorable wait-function))
159 (with-slots (event-count) port
160 (if *multiprocessing-p*
161 (let ((old-event-count (or old-count event-count))
162 (flag nil))
163 (flet ((wait-fn ()
164 (when (not (eql old-event-count event-count))
165 (setq flag t))))
166 (if timeout
167 (process-wait-with-timeout "Wait for event" timeout #'wait-fn)
168 (process-wait "Wait for event" #'wait-fn))
169 (if flag
170 event-count
171 (values nil :timeout))))
172 (multiple-value-bind (result reason)
173 (process-next-event port
174 :wait-function wait-function
175 :timeout timeout)
176 (values (and result event-count) reason)))))
177
178 (defmethod distribute-event ((port basic-port) event)
179 (cond
180 ((typep event 'keyboard-event)
181 (dispatch-event (or (port-keyboard-input-focus port) (event-sheet event))
182 event))
183 ((typep event 'window-event)
184 ; (dispatch-event (window-event-mirrored-sheet event) event)
185 (dispatch-event (event-sheet event) event))
186 ((typep event 'pointer-event)
187 (dispatch-event (event-sheet event) event))
188 ((typep event 'window-manager-delete-event)
189 ;; not sure where this type of event should get sent - mikemac
190 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
191 (dispatch-event (event-sheet event) event))
192 ((typep event 'timer-event)
193 (error "Where do we send timer-events?"))
194 (t
195 (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
196
197 (defmacro with-port-locked ((port) &body body)
198 (let ((fn (gensym "CONT.")))
199 `(labels ((,fn ()
200 ,@body))
201 (declare (dynamic-extent #',fn))
202 (invoke-with-port-locked ,port #',fn))))
203
204 (defmethod invoke-with-port-locked ((port basic-port) continuation)
205 (with-recursive-lock-held ((port-lock port))
206 (funcall continuation)))
207
208 (defun map-over-ports (function)
209 (mapc function *all-ports*))
210
211 (defmethod restart-port ((port basic-port))
212 (reset-watcher port :restart)
213 nil)
214
215 (defmethod destroy-port ((port basic-port))
216 (reset-watcher port :destroy)
217 (setf *all-ports* (remove port *all-ports*)))
218
219 (defmethod add-watcher ((port basic-port) watcher)
220 (declare (ignore watcher))
221 nil)
222
223 (defmethod delete-watcher ((port basic-port) watcher)
224 (declare (ignore watcher))
225 nil)
226
227 (defmethod reset-watcher ((port basic-port) how)
228 (declare (ignore how))
229 nil)
230
231 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
232 (let ((graft (make-instance 'graft
233 :port port :mirror nil
234 :orientation orientation :units units)))
235 (push graft (port-grafts port))
236 graft))
237
238 #||
239 (defmethod make-medium ((port basic-port) sheet)
240 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
241 ||#
242
243 ;;; Pixmap
244
245 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
246 (gethash pixmap (slot-value port 'pixmap->mirror)))
247
248 (defmethod port-lookup-pixmap ((port basic-port) mirror)
249 (gethash mirror (slot-value port 'mirror->pixmap)))
250
251 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
252 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
253 (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
254 nil)
255
256 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
257 (remhash pixmap (slot-value port 'pixmap->mirror))
258 (remhash mirror (slot-value port 'mirror->pixmap))
259 nil)
260
261 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
262 (declare (ignorable port pixmap))
263 (error "Don't know how to realize the mirror on a generic port"))
264
265 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
266 (declare (ignorable port pixmap))
267 (error "Don't know how to destroy the mirror on a generic port"))
268
269 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
270 (declare (ignore sheet width height))
271 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
272
273 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
274 (declare (ignore pixmap))
275 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))

  ViewVC Help
Powered by ViewVC 1.1.5