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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.24 - (show annotations)
Wed Feb 27 23:13:34 2002 UTC (12 years, 1 month ago) by mikemac
Branch: MAIN
Changes since 1.23: +1 -1 lines
make window-manager-delete-event work
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* '(:clx :x11 :genera))
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
71 (defun find-port (&key (server-path *default-server-path*))
72 (if (null server-path)
73 (setq server-path (find-default-server-path)))
74 (if (atom server-path)
75 (setq server-path (list server-path)))
76 (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
77 (loop for port in *all-ports*
78 if (equal server-path (port-server-path port))
79 do (return port)
80 finally (let ((port-type (get (first server-path) :port-type))
81 port)
82 (if (null port-type)
83 (error "Don't know how to make a port of type ~S" server-path))
84 (setq port (funcall 'make-instance port-type :server-path server-path))
85 (push port *all-ports*)
86 (return port))))
87
88 (defmethod initialize-instance :after ((port basic-port) &rest args)
89 (declare (ignorable args))
90 )
91
92 (defmethod destroy-port :before ((port basic-port))
93 (when *multiprocessing-p*
94 (destroy-process (port-event-process port))
95 (setf (port-event-process port) nil)))
96
97 (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
98 (gethash sheet (slot-value port 'sheet->mirror)))
99
100 (defmethod port-lookup-sheet ((port basic-port) mirror)
101 (gethash mirror (slot-value port 'mirror->sheet)))
102
103 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
104 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
105 (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
106 nil)
107
108 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
109 (remhash sheet (slot-value port 'sheet->mirror))
110 (remhash mirror (slot-value port 'mirror->sheet))
111 nil)
112
113 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
114 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
115
116 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
117 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
118
119 (defmethod mirror-transformation ((port basic-port) mirror)
120 (declare (ignore mirror))
121 (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
122
123 (defmethod port-properties ((port basic-port) indicator)
124 (with-slots (properties) port
125 (getf properties indicator)))
126
127 (defmethod (setf port-properties) (value (port basic-port) indicator)
128 (with-slots (properties) port
129 (setf (getf properties indicator) value)))
130
131 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
132 (declare (ignore wait-function timeout))
133 (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
134
135 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
136 (let ((event (get-next-event port :wait-function wait-function :timeout timeout)))
137 (cond
138 ((null event) nil)
139 ((eq event :timeout) (values nil :timeout))
140 (t
141 (distribute-event port event)
142 t))))
143
144 (defmethod distribute-event ((port basic-port) event)
145 (cond
146 ((typep event 'keyboard-event)
147 (dispatch-event (or (port-keyboard-input-focus port)
148 (event-sheet event)) event))
149 ((typep event 'window-event)
150 ; (dispatch-event (window-event-mirrored-sheet event) event))
151 (dispatch-event (event-sheet event) event))
152 ((typep event 'pointer-event)
153 (dispatch-event (event-sheet event) event))
154 ((typep event 'window-manager-delete-event)
155 ;; not sure where this type of event should get sent - mikemac
156 (queue-event (frame-standard-input (pane-frame (event-sheet event))) event))
157 ((typep event 'timer-event)
158 (error "Where do we send timer-events?"))
159 (t
160 (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
161
162 (defmacro with-port-locked ((port) &body body)
163 (let ((fn (gensym "CONT.")))
164 `(labels ((,fn ()
165 ,@body))
166 (declare (dynamic-extent #',fn))
167 `(invoke-with-port-locked ,port #',fn))))
168
169 (defmethod invoke-with-port-locked ((port basic-port) continuation)
170 (with-recursive-lock-held ((port-lock port))
171 (funcall continuation)))
172
173 (defun map-over-ports (function)
174 (mapc function *all-ports*))
175
176 (defmethod restart-port ((port basic-port))
177 (reset-watcher port :restart)
178 nil)
179
180 (defmethod destroy-port ((port basic-port))
181 (reset-watcher port :destroy)
182 (setf *all-ports* (remove port *all-ports*)))
183
184 (defmethod add-watcher ((port basic-port) watcher)
185 (declare (ignore watcher))
186 nil)
187
188 (defmethod delete-watcher ((port basic-port) watcher)
189 (declare (ignore watcher))
190 nil)
191
192 (defmethod reset-watcher ((port basic-port) how)
193 (declare (ignore how))
194 nil)
195
196 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
197 (let ((graft (make-instance 'graft
198 :port port :mirror nil
199 :orientation orientation :units units)))
200 (push graft (port-grafts port))
201 graft))
202
203 #||
204 (defmethod make-medium ((port basic-port) sheet)
205 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
206 ||#
207
208 ;;; Pixmap
209
210 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
211 (gethash pixmap (slot-value port 'pixmap->mirror)))
212
213 (defmethod port-lookup-pixmap ((port basic-port) mirror)
214 (gethash mirror (slot-value port 'mirror->pixmap)))
215
216 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
217 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
218 (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
219 nil)
220
221 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
222 (remhash pixmap (slot-value port 'pixmap->mirror))
223 (remhash mirror (slot-value port 'mirror->pixmap))
224 nil)
225
226 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
227 (declare (ignorable port pixmap))
228 (error "Don't know how to realize the mirror on a generic port"))
229
230 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
231 (declare (ignorable port pixmap))
232 (error "Don't know how to destroy the mirror on a generic port"))
233
234 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
235 (declare (ignore sheet width height))
236 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
237
238 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
239 (declare (ignore pixmap))
240 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))

  ViewVC Help
Powered by ViewVC 1.1.5