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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.51 - (show annotations)
Mon Mar 27 10:44:34 2006 UTC (8 years ago) by crhodes
Branch: MAIN
Changes since 1.50: +1 -1 lines
Whoops.  A missing piece of the Null backend.  Put :null at the end of
*server-path-search-order*.
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 :beagle :null))
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 basic-port (port)
39 ((server-path :initform nil
40 :initarg :server-path
41 :reader port-server-path)
42 (properties :initform nil
43 :initarg :properties)
44 (grafts :initform nil
45 :accessor port-grafts)
46 (frame-managers :initform nil
47 :reader frame-managers)
48 (sheet->mirror :initform (make-hash-table :test #'eq))
49 (mirror->sheet :initform (make-hash-table :test #'eq))
50 (pixmap->mirror :initform (make-hash-table :test #'eq))
51 (mirror->pixmap :initform (make-hash-table :test #'eq))
52 #+ignore (keyboard-input-focus :initform nil ;; nuked this, see below
53 :initarg :keyboard-input-focus
54 :accessor port-keyboard-input-focus)
55 (event-process
56 :initform nil
57 :initarg :event-process
58 :accessor port-event-process
59 :documentation "In a multiprocessing environment, the particular process
60 reponsible for calling PROCESS-NEXT-EVENT in a loop.")
61
62 (lock
63 :initform (make-recursive-lock "port lock")
64 :accessor port-lock)
65 (event-count :initform 0)
66 (text-style-mappings :initform (make-hash-table :test #'eq)
67 :reader port-text-style-mappings)
68 (pointer-sheet :initform nil :accessor port-pointer-sheet
69 :documentation "The sheet the pointer is over, if any")
70 ))
71
72 ;; Keyboard focus is now managed per-frame rather than per-port,
73 ;; which makes a lot of sense (less sense in the presense of
74 ;; multiple top-level windows, but no one does that yet). The CLIM
75 ;; spec suggests this in a "Minor Issue". So, redirect
76 ;; PORT-KEYBOARD-INPUT-FOCUS to the current application frame
77 ;; for compatibility.
78
79 ;; Note: This would prevent you from using the function the
80 ;; function to query who currently has the focus. I don't
81 ;; know if this is an intended use or not.
82
83 ;; The big picture:
84 ;; PORT-KEYBOARD-INPUT-FOCUS is defined by CLIM 2.0
85 ;; Our default method on this delegates to KEYBOARD-INPUT-FOCUS
86 ;; on the current application frame.
87 ;; %SET-PORT-KEYBOARD-FOCUS is the function which
88 ;; should be implemented in a McCLIM backend and
89 ;; does the work of changing the focus.
90 ;; A method on (SETF KEYBOARD-INPUT-FOCUS) brings them together,
91 ;; calling %SET-PORT-KEYBOARD-FOCUS.
92
93 (defgeneric port-keyboard-input-focus (port))
94 (defgeneric (setf port-keyboard-input-focus) (focus port))
95
96 (defmethod port-keyboard-input-focus (port)
97 (declare (ignore port))
98 (when *application-frame*
99 (keyboard-input-focus *application-frame*)))
100
101 (defmethod (setf port-keyboard-input-focus) (focus port)
102 (when focus
103 (if (pane-frame focus)
104 (setf (keyboard-input-focus (pane-frame focus)) focus)
105 (%set-port-keyboard-focus port focus))))
106
107 ;; This is not in the CLIM spec, but since (setf port-keyboard-input-focus)
108 ;; now calls (setf keyboard-input-focus), we need something concrete the
109 ;; backend can implement to set the focus.
110 (defmethod %set-port-keyboard-focus (port focus &key timestamp)
111 (declare (ignore focus timestamp))
112 (warn "%SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port))
113
114
115 (defun find-port (&key (server-path *default-server-path*))
116 (if (null server-path)
117 (setq server-path (find-default-server-path)))
118 (if (atom server-path)
119 (setq server-path (list server-path)))
120 (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
121 (loop for port in *all-ports*
122 if (equal server-path (port-server-path port))
123 do (return port)
124 finally (let ((port-type (get (first server-path) :port-type))
125 port)
126 (if (null port-type)
127 (error "Don't know how to make a port of type ~S" server-path))
128 (setq port (funcall 'make-instance port-type :server-path server-path))
129 (push port *all-ports*)
130 (return port))))
131
132 (defmethod initialize-instance :after ((port basic-port) &rest args)
133 (declare (ignorable args))
134 )
135
136 (defmethod destroy-port :before ((port basic-port))
137 (when (and *multiprocessing-p* (port-event-process port))
138 (destroy-process (port-event-process port))
139 (setf (port-event-process port) nil)))
140
141 (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
142 (gethash sheet (slot-value port 'sheet->mirror)))
143
144 (defmethod port-lookup-sheet ((port basic-port) mirror)
145 (gethash mirror (slot-value port 'mirror->sheet)))
146
147 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
148 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
149 (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
150 nil)
151
152 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
153 (remhash sheet (slot-value port 'sheet->mirror))
154 (remhash mirror (slot-value port 'mirror->sheet))
155 nil)
156
157 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
158 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
159
160 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
161 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
162
163 (defmethod mirror-transformation ((port basic-port) mirror)
164 (declare (ignore mirror))
165 (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
166
167 (defmethod port-properties ((port basic-port) indicator)
168 (with-slots (properties) port
169 (getf properties indicator)))
170
171 (defmethod (setf port-properties) (value (port basic-port) indicator)
172 (with-slots (properties) port
173 (setf (getf properties indicator) value)))
174
175 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
176 (declare (ignore wait-function timeout))
177 (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
178
179 (defmethod get-next-event :after ((port basic-port) &key wait-function timeout)
180 (declare (ignore wait-function timeout))
181 (with-slots (event-count) port
182 (incf event-count)))
183
184 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
185 (let ((event (get-next-event port
186 :wait-function wait-function
187 :timeout timeout)))
188 (cond
189 ((null event) nil)
190 ((eq event :timeout) (values nil :timeout))
191 (t
192 (distribute-event port event)
193 t))))
194
195 (defmethod distribute-event ((port basic-port) event)
196 (cond
197 ((typep event 'keyboard-event)
198 (dispatch-event (or #+ignore(port-keyboard-input-focus port) (event-sheet event))
199 event))
200 ((typep event 'window-event)
201 ; (dispatch-event (window-event-mirrored-sheet event) event)
202 (dispatch-event (event-sheet event) event))
203 ((typep event 'pointer-event)
204 (dispatch-event (event-sheet event) event))
205 ((typep event 'window-manager-delete-event)
206 ;; not sure where this type of event should get sent - mikemac
207 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
208 (dispatch-event (event-sheet event) event))
209 ((typep event 'timer-event)
210 (error "Where do we send timer-events?"))
211 (t
212 (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
213
214 (defmacro with-port-locked ((port) &body body)
215 (let ((fn (gensym "CONT.")))
216 `(labels ((,fn ()
217 ,@body))
218 (declare (dynamic-extent #',fn))
219 (invoke-with-port-locked ,port #',fn))))
220
221 (defmethod invoke-with-port-locked ((port basic-port) continuation)
222 (with-recursive-lock-held ((port-lock port))
223 (funcall continuation)))
224
225 (defun map-over-ports (function)
226 (mapc function *all-ports*))
227
228 (defmethod restart-port ((port basic-port))
229 (reset-watcher port :restart)
230 nil)
231
232 (defmethod destroy-port ((port basic-port))
233 (reset-watcher port :destroy)
234 (setf *all-ports* (remove port *all-ports*)))
235
236 (defmethod add-watcher ((port basic-port) watcher)
237 (declare (ignore watcher))
238 nil)
239
240 (defmethod delete-watcher ((port basic-port) watcher)
241 (declare (ignore watcher))
242 nil)
243
244 (defmethod reset-watcher ((port basic-port) how)
245 (declare (ignore how))
246 nil)
247
248 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
249 (let ((graft (make-instance 'graft
250 :port port :mirror nil
251 :orientation orientation :units units)))
252 (push graft (port-grafts port))
253 graft))
254
255 #||
256 (defmethod make-medium ((port basic-port) sheet)
257 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
258 ||#
259
260 ;;; Pixmap
261
262 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
263 (gethash pixmap (slot-value port 'pixmap->mirror)))
264
265 (defmethod port-lookup-pixmap ((port basic-port) mirror)
266 (gethash mirror (slot-value port 'mirror->pixmap)))
267
268 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
269 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
270 (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
271 nil)
272
273 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
274 (remhash pixmap (slot-value port 'pixmap->mirror))
275 (remhash mirror (slot-value port 'mirror->pixmap))
276 nil)
277
278 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
279 (declare (ignorable port pixmap))
280 (error "Don't know how to realize the mirror on a generic port"))
281
282 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
283 (declare (ignorable port pixmap))
284 (error "Don't know how to destroy the mirror on a generic port"))
285
286 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
287 (declare (ignore sheet width height))
288 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
289
290 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
291 (declare (ignore pixmap))
292 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))
293
294
295 (defgeneric port-force-output (port)
296 (:documentation "Flush the output buffer of PORT, if there is one."))
297
298 (defmethod port-force-output ((port basic-port))
299 (values))
300
301 (defgeneric port-grab-pointer (port pointer sheet)
302 (:documentation "Grab the specified pointer, for implementing TRACKING-POINTER."))
303
304 (defgeneric port-ungrab-pointer (port pointer sheet)
305 (:documentation "Ungrab the specified pointer, for implementing TRACKING-POINTER."))
306
307 (defmethod port-grab-pointer ((port basic-port) pointer sheet)
308 (declare (ignorable port pointer sheet))
309 (warn "Port ~A has not implemented pointer grabbing." port))
310
311 (defmethod port-ungrab-pointer ((port basic-port) pointer sheet)
312 (declare (ignorable port pointer sheet))
313 (warn "Port ~A has not implemented pointer grabbing." port))
314
315 (defgeneric set-sheet-pointer-cursor (port sheet cursor)
316 (:documentation "Sets the cursor associated with SHEET. CURSOR is a symbol, as described in the Franz user's guide."))
317
318 (defmethod set-sheet-pointer-cursor ((port basic-port) sheet cursor)
319 (declare (ignore sheet cursor))
320 (warn "Port ~A has not implemented sheet pointer cursors." port))

  ViewVC Help
Powered by ViewVC 1.1.5