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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (show annotations)
Sun Apr 21 12:41:14 2002 UTC (12 years ago) by brian
Branch: MAIN
Changes since 1.27: +11 -2 lines
Sundry fixes to run without multiprocessing support.

Added images/ to hold bitmaps for tests.

Added looks/ to hold neutral look-and-feel realizer packages.

Added Examples/gadget-test to test many gadgets with a look and feel.

Added a pixie look and feel, and a pixie/clx to work with the clx backend.

Added drawing support in the CLX backend for ovals and circles.

Fixed pixmaps to work with with-output-to-pixmap with draw-image, etc.

Moved sheet-leaf-mixin to standard-gadget-pane so it doesn't break radio-box-pane, etc.

Misc fixes.
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 (event-count :initform 0)
71 ))
72
73 (defun find-port (&key (server-path *default-server-path*))
74 (if (null server-path)
75 (setq server-path (find-default-server-path)))
76 (if (atom server-path)
77 (setq server-path (list server-path)))
78 (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
79 (loop for port in *all-ports*
80 if (equal server-path (port-server-path port))
81 do (return port)
82 finally (let ((port-type (get (first server-path) :port-type))
83 port)
84 (if (null port-type)
85 (error "Don't know how to make a port of type ~S" server-path))
86 (setq port (funcall 'make-instance port-type :server-path server-path))
87 (push port *all-ports*)
88 (return port))))
89
90 (defmethod initialize-instance :after ((port basic-port) &rest args)
91 (declare (ignorable args))
92 )
93
94 (defmethod destroy-port :before ((port basic-port))
95 (when *multiprocessing-p*
96 (destroy-process (port-event-process port))
97 (setf (port-event-process port) nil)))
98
99 (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
100 (gethash sheet (slot-value port 'sheet->mirror)))
101
102 (defmethod port-lookup-sheet ((port basic-port) mirror)
103 (gethash mirror (slot-value port 'mirror->sheet)))
104
105 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
106 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
107 (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
108 nil)
109
110 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
111 (remhash sheet (slot-value port 'sheet->mirror))
112 (remhash mirror (slot-value port 'mirror->sheet))
113 nil)
114
115 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
116 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
117
118 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
119 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
120
121 (defmethod mirror-transformation ((port basic-port) mirror)
122 (declare (ignore mirror))
123 (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
124
125 (defmethod port-properties ((port basic-port) indicator)
126 (with-slots (properties) port
127 (getf properties indicator)))
128
129 (defmethod (setf port-properties) (value (port basic-port) indicator)
130 (with-slots (properties) port
131 (setf (getf properties indicator) value)))
132
133 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
134 (declare (ignore wait-function timeout))
135 (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
136
137 (defmethod get-next-event :after ((port basic-port) &key wait-function timeout)
138 (declare (ignore wait-function timeout))
139 (with-slots (event-count) port
140 (incf event-count)))
141
142 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
143 (let ((event (get-next-event port
144 :wait-function wait-function
145 :timeout timeout)))
146 (cond
147 ((null event) nil)
148 ((eq event :timeout) (values nil :timeout))
149 (t
150 (distribute-event port event)
151 t))))
152
153 ;;; Called in the application frame process.
154 (defmethod port-wait-on-event-processing ((port basic-port) &key wait-function timeout
155 ((:event-count old-count) nil))
156 (declare (ignorable wait-function))
157 (if *multiprocessing-p*
158 (with-slots (event-count) port
159 (let ((old-event-count (or old-count event-count))
160 (flag nil))
161 #|
162 (process-wait-with-timeout "Wait for event" timeout
163 #'(lambda ()
164 (when (not (= old-event-count event-count))
165 (setq flag t))))
166 (if flag
167 event-count
168 (values nil :timeout))
169 (process-next-event port :wait-function wait-function :timeout timeout)
170 |#
171 (flet ((wait-fn ()
172 (when (not (eql old-event-count event-count))
173 (setq flag t))))
174 (if timeout
175 (process-wait-with-timeout "Wait for event" timeout #'wait-fn)
176 (process-wait "Wait for event" #'wait-fn))
177 (if flag
178 event-count
179 (values nil :timeout)))))
180 (multiple-value-bind (result reason)
181 (process-next-event port
182 :wait-function wait-function
183 :timeout timeout)
184 (values (and result event-count) reason))))
185
186 (defmethod distribute-event ((port basic-port) event)
187 (cond
188 ((typep event 'keyboard-event)
189 (dispatch-event (or (port-keyboard-input-focus port) (event-sheet event))
190 event))
191 ((typep event 'window-event)
192 ; (dispatch-event (window-event-mirrored-sheet event) event)
193 (dispatch-event (event-sheet event) event))
194 ((typep event 'pointer-event)
195 (dispatch-event (event-sheet event) event))
196 ((typep event 'window-manager-delete-event)
197 ;; not sure where this type of event should get sent - mikemac
198 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
199 (dispatch-event (event-sheet event) event))
200 ((typep event 'timer-event)
201 (error "Where do we send timer-events?"))
202 (t
203 (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
204
205 (defmacro with-port-locked ((port) &body body)
206 (let ((fn (gensym "CONT.")))
207 `(labels ((,fn ()
208 ,@body))
209 (declare (dynamic-extent #',fn))
210 `(invoke-with-port-locked ,port #',fn))))
211
212 (defmethod invoke-with-port-locked ((port basic-port) continuation)
213 (with-recursive-lock-held ((port-lock port))
214 (funcall continuation)))
215
216 (defun map-over-ports (function)
217 (mapc function *all-ports*))
218
219 (defmethod restart-port ((port basic-port))
220 (reset-watcher port :restart)
221 nil)
222
223 (defmethod destroy-port ((port basic-port))
224 (reset-watcher port :destroy)
225 (setf *all-ports* (remove port *all-ports*)))
226
227 (defmethod add-watcher ((port basic-port) watcher)
228 (declare (ignore watcher))
229 nil)
230
231 (defmethod delete-watcher ((port basic-port) watcher)
232 (declare (ignore watcher))
233 nil)
234
235 (defmethod reset-watcher ((port basic-port) how)
236 (declare (ignore how))
237 nil)
238
239 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
240 (let ((graft (make-instance 'graft
241 :port port :mirror nil
242 :orientation orientation :units units)))
243 (push graft (port-grafts port))
244 graft))
245
246 #||
247 (defmethod make-medium ((port basic-port) sheet)
248 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
249 ||#
250
251 ;;; Pixmap
252
253 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
254 (gethash pixmap (slot-value port 'pixmap->mirror)))
255
256 (defmethod port-lookup-pixmap ((port basic-port) mirror)
257 (gethash mirror (slot-value port 'mirror->pixmap)))
258
259 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
260 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
261 (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
262 nil)
263
264 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
265 (remhash pixmap (slot-value port 'pixmap->mirror))
266 (remhash mirror (slot-value port 'mirror->pixmap))
267 nil)
268
269 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
270 (declare (ignorable port pixmap))
271 (error "Don't know how to realize the mirror on a generic port"))
272
273 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
274 (declare (ignorable port pixmap))
275 (error "Don't know how to destroy the mirror on a generic port"))
276
277 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
278 (declare (ignore sheet width height))
279 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
280
281 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
282 (declare (ignore pixmap))
283 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))

  ViewVC Help
Powered by ViewVC 1.1.5