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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.42 - (show annotations)
Sun Sep 14 17:55:56 2003 UTC (10 years, 7 months ago) by hefner1
Branch: MAIN
CVS Tags: McCLIM-0-9
Changes since 1.41: +6 -0 lines
Attempt to address the annoying CLX buffering issues, by calling
XLIB:DISPLAY-FORCE-OUTPUT when applications check their event queues.

* Created a subclass of STANDARD-EVENT-QUEUE called PORT-EVENT-QUEUE, which
  knows what port will be putting events on the queue. (Arguably I could've
  just added a port slot to STANDARD-EVENT-QUEUE either directly or through
  a mixin, or even added a slot for a "force output" hook, but this is what
  I've done for now.)

* When creating frames or sheet-with-input-mixins, use PORT-EVENT-QUEUE
  instead and initialize the PORT slot.

* Introduced a new method, PORT-FORCE-OUTPUT.

* Wrote :before methods on EVENT-QUEUE-READ, EVENT-QUEUE-PEEK, etc, which
  call PORT-FORCE-OUTPUT.

* Before exiting RUN-FRAME-TOPLEVEL, be sure to get the port from the frame
  manager and call PORT-FORCE-OUTPUT on that too, to make sure the app
  window really goes away when it should instead of being stuck in limbo.

* Also squashed a couple warnings in Backends/CLX/image.lisp from bad format
  strings to ERROR.
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 (define-protocol-class port ())
39
40 (defclass basic-port (port)
41 ((server-path :initform nil
42 :initarg :server-path
43 :reader port-server-path)
44 (properties :initform nil
45 :initarg :properties)
46 (grafts :initform nil
47 :accessor port-grafts)
48 (frame-managers :initform nil
49 :reader frame-managers)
50 (sheet->mirror :initform (make-hash-table :test #'eq))
51 (mirror->sheet :initform (make-hash-table :test #'eq))
52 (pixmap->mirror :initform (make-hash-table :test #'eq))
53 (mirror->pixmap :initform (make-hash-table :test #'eq))
54 #+ignore (keyboard-input-focus :initform nil ;; nuked this, see below
55 :initarg :keyboard-input-focus
56 :accessor port-keyboard-input-focus)
57 (event-process
58 :initform nil
59 :initarg :event-process
60 :accessor port-event-process
61 :documentation "In a multiprocessing environment, the particular process
62 reponsible for calling PROCESS-NEXT-EVENT in a loop.")
63
64 (lock
65 :initform (make-recursive-lock "port lock")
66 :accessor port-lock)
67 (event-count :initform 0)
68 (text-style-mappings :initform (make-hash-table :test #'eq)
69 :reader port-text-style-mappings)
70 (pointer-sheet :initform nil :accessor port-pointer-sheet
71 :documentation "The sheet the pointer is over, if any")
72 ))
73
74 ;; Keyboard focus is now managed per-frame rather than per-port,
75 ;; which makes a lot of sense. The CLIM spec suggests this in a
76 ;; "Minor Issue". So, redirect PORT-KEYBOARD-INPUT-FOCUS to the
77 ;; current application frame for compatibility.
78 (defmethod port-keyboard-input-focus (port)
79 (declare (ignore port))
80 (when *application-frame*
81 (keyboard-input-focus *application-frame*)))
82
83 (defmethod (setf port-keyboard-input-focus) (focus port)
84 (when focus
85 (if (pane-frame focus)
86 (setf (keyboard-input-focus (pane-frame focus)) focus)
87 (set-port-keyboard-focus focus port))))
88
89 ;; This is not in the CLIM spec, but since (setf port-keyboard-input-focus)
90 ;; now calls (setf keyboard-input-focus), we need something concrete the
91 ;; backend can implement to set the focus.
92 (defmethod set-port-keyboard-focus (focus port)
93 (declare (ignore focus))
94 (warn "SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port))
95
96
97 (defun find-port (&key (server-path *default-server-path*))
98 (if (null server-path)
99 (setq server-path (find-default-server-path)))
100 (if (atom server-path)
101 (setq server-path (list server-path)))
102 (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
103 (loop for port in *all-ports*
104 if (equal server-path (port-server-path port))
105 do (return port)
106 finally (let ((port-type (get (first server-path) :port-type))
107 port)
108 (if (null port-type)
109 (error "Don't know how to make a port of type ~S" server-path))
110 (setq port (funcall 'make-instance port-type :server-path server-path))
111 (push port *all-ports*)
112 (return port))))
113
114 (defmethod initialize-instance :after ((port basic-port) &rest args)
115 (declare (ignorable args))
116 )
117
118 (defmethod destroy-port :before ((port basic-port))
119 (when (and *multiprocessing-p* (port-event-process port))
120 (destroy-process (port-event-process port))
121 (setf (port-event-process port) nil)))
122
123 (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
124 (gethash sheet (slot-value port 'sheet->mirror)))
125
126 (defmethod port-lookup-sheet ((port basic-port) mirror)
127 (gethash mirror (slot-value port 'mirror->sheet)))
128
129 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
130 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
131 (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
132 nil)
133
134 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
135 (remhash sheet (slot-value port 'sheet->mirror))
136 (remhash mirror (slot-value port 'mirror->sheet))
137 nil)
138
139 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
140 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
141
142 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
143 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
144
145 (defmethod mirror-transformation ((port basic-port) mirror)
146 (declare (ignore mirror))
147 (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
148
149 (defmethod port-properties ((port basic-port) indicator)
150 (with-slots (properties) port
151 (getf properties indicator)))
152
153 (defmethod (setf port-properties) (value (port basic-port) indicator)
154 (with-slots (properties) port
155 (setf (getf properties indicator) value)))
156
157 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
158 (declare (ignore wait-function timeout))
159 (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
160
161 (defmethod get-next-event :after ((port basic-port) &key wait-function timeout)
162 (declare (ignore wait-function timeout))
163 (with-slots (event-count) port
164 (incf event-count)))
165
166 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
167 (let ((event (get-next-event port
168 :wait-function wait-function
169 :timeout timeout)))
170 (cond
171 ((null event) nil)
172 ((eq event :timeout) (values nil :timeout))
173 (t
174 (distribute-event port event)
175 t))))
176
177 ;;; Called in the application frame process.
178 (defmethod port-wait-on-event-processing ((port basic-port) &key wait-function timeout
179 ((:event-count old-count) nil))
180 (declare (ignorable wait-function))
181 (with-slots (event-count) port
182 (if *multiprocessing-p*
183 (let ((old-event-count (or old-count event-count))
184 (flag nil))
185 (flet ((wait-fn ()
186 (when (not (eql old-event-count event-count))
187 (setq flag t))))
188 (if timeout
189 (process-wait-with-timeout "Wait for event" timeout #'wait-fn)
190 (process-wait "Wait for event" #'wait-fn))
191 (if flag
192 event-count
193 (values nil :timeout))))
194 (multiple-value-bind (result reason)
195 (process-next-event port
196 :wait-function wait-function
197 :timeout timeout)
198 (values (and result event-count) reason)))))
199
200 (defmethod distribute-event ((port basic-port) event)
201 (cond
202 ((typep event 'keyboard-event)
203 (dispatch-event (or #+ignore(port-keyboard-input-focus port) (event-sheet event))
204 event))
205 ((typep event 'window-event)
206 ; (dispatch-event (window-event-mirrored-sheet event) event)
207 (dispatch-event (event-sheet event) event))
208 ((typep event 'pointer-event)
209 (dispatch-event (event-sheet event) event))
210 ((typep event 'window-manager-delete-event)
211 ;; not sure where this type of event should get sent - mikemac
212 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
213 (dispatch-event (event-sheet event) event))
214 ((typep event 'timer-event)
215 (error "Where do we send timer-events?"))
216 (t
217 (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
218
219 (defmacro with-port-locked ((port) &body body)
220 (let ((fn (gensym "CONT.")))
221 `(labels ((,fn ()
222 ,@body))
223 (declare (dynamic-extent #',fn))
224 (invoke-with-port-locked ,port #',fn))))
225
226 (defmethod invoke-with-port-locked ((port basic-port) continuation)
227 (with-recursive-lock-held ((port-lock port))
228 (funcall continuation)))
229
230 (defun map-over-ports (function)
231 (mapc function *all-ports*))
232
233 (defmethod restart-port ((port basic-port))
234 (reset-watcher port :restart)
235 nil)
236
237 (defmethod destroy-port ((port basic-port))
238 (reset-watcher port :destroy)
239 (setf *all-ports* (remove port *all-ports*)))
240
241 (defmethod add-watcher ((port basic-port) watcher)
242 (declare (ignore watcher))
243 nil)
244
245 (defmethod delete-watcher ((port basic-port) watcher)
246 (declare (ignore watcher))
247 nil)
248
249 (defmethod reset-watcher ((port basic-port) how)
250 (declare (ignore how))
251 nil)
252
253 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
254 (let ((graft (make-instance 'graft
255 :port port :mirror nil
256 :orientation orientation :units units)))
257 (push graft (port-grafts port))
258 graft))
259
260 #||
261 (defmethod make-medium ((port basic-port) sheet)
262 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
263 ||#
264
265 ;;; Pixmap
266
267 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
268 (gethash pixmap (slot-value port 'pixmap->mirror)))
269
270 (defmethod port-lookup-pixmap ((port basic-port) mirror)
271 (gethash mirror (slot-value port 'mirror->pixmap)))
272
273 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
274 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
275 (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
276 nil)
277
278 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
279 (remhash pixmap (slot-value port 'pixmap->mirror))
280 (remhash mirror (slot-value port 'mirror->pixmap))
281 nil)
282
283 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
284 (declare (ignorable port pixmap))
285 (error "Don't know how to realize the mirror on a generic port"))
286
287 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
288 (declare (ignorable port pixmap))
289 (error "Don't know how to destroy the mirror on a generic port"))
290
291 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
292 (declare (ignore sheet width height))
293 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
294
295 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
296 (declare (ignore pixmap))
297 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))
298
299
300 (defgeneric port-force-output (port))
301
302 (defmethod port-force-output ((port basic-port))
303 (values))

  ViewVC Help
Powered by ViewVC 1.1.5