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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.56 - (show annotations)
Wed Mar 14 23:33:24 2007 UTC (7 years, 1 month ago) by dlichteblau
Branch: MAIN
CVS Tags: McCLIM-0-9-5, McCLIM-0-9-6, HEAD
Changes since 1.55: +12 -1 lines
Added the native windows backend clim-graphic-forms, by Jack D. Unrue
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 ;; - CLX is the de-facto reference backend.
29 ;; - Prefer Graphic-Forms and Gtkairo over CLX, since they get installed only
30 ;; on explicit user request anyway.
31 ;; - If both are present, use Graphics-Forms in favour of Gtkairo, since
32 ;; it is the native Windows backend.
33 ;; - Beagle should be treated like Graphic-Forms in the long term, but is
34 ;; currently lacking a maintainer, so let's leave it near the end.
35 ;; - OpenGL and Null are in this list mostly to document their existence,
36 ;; and neither is currently a complete backend we would want to make
37 ;; a default. Put them after CLX, so that they won't actually be reached.
38 (defvar *server-path-search-order*
39 '(:graphic-forms :gtkairo :clx :opengl :beagle :null))
40
41 (defun find-default-server-path ()
42 (loop for port in *server-path-search-order*
43 if (get port :port-type)
44 do (return-from find-default-server-path (list port))
45 finally (error "No CLIM backends have been loaded!")))
46
47 (defvar *all-ports* nil)
48
49 (defclass basic-port (port)
50 ((server-path :initform nil
51 :initarg :server-path
52 :reader port-server-path)
53 (properties :initform nil
54 :initarg :properties)
55 (grafts :initform nil
56 :accessor port-grafts)
57 (frame-managers :initform nil
58 :reader frame-managers)
59 (sheet->mirror :initform (make-hash-table :test #'eq))
60 (mirror->sheet :initform (make-hash-table :test #'eq))
61 (pixmap->mirror :initform (make-hash-table :test #'eq))
62 (mirror->pixmap :initform (make-hash-table :test #'eq))
63 (event-process
64 :initform nil
65 :initarg :event-process
66 :accessor port-event-process
67 :documentation "In a multiprocessing environment, the particular process
68 reponsible for calling PROCESS-NEXT-EVENT in a loop.")
69
70 (lock
71 :initform (make-recursive-lock "port lock")
72 :accessor port-lock)
73 (event-count :initform 0)
74 (text-style-mappings :initform (make-hash-table :test #'eq)
75 :reader port-text-style-mappings)
76 (pointer-sheet :initform nil :accessor port-pointer-sheet
77 :documentation "The sheet the pointer is over, if any")))
78
79 (defmethod port-keyboard-input-focus (port)
80 (when (null *application-frame*)
81 (error "~S called with null ~S"
82 'port-keyboard-input-focus '*application-frame*))
83 (port-frame-keyboard-input-focus port *application-frame*))
84 (defmethod (setf port-keyboard-input-focus) (focus port)
85 (when (null *application-frame*)
86 (error "~S called with null ~S"
87 '(setf port-keyboard-input-focus) '*application-frame*))
88 (unless (eq *application-frame* (pane-frame focus))
89 (error "frame mismatch in ~S" '(setf port-keyboard-input-focus)))
90 (setf (port-frame-keyboard-input-focus port *application-frame*) focus))
91
92 (defgeneric port-frame-keyboard-input-focus (port frame))
93 (defgeneric (setf port-frame-keyboard-input-focus) (focus port frame))
94
95 (defun find-port (&key (server-path *default-server-path*))
96 (if (null server-path)
97 (setq server-path (find-default-server-path)))
98 (if (atom server-path)
99 (setq server-path (list server-path)))
100 (setq server-path (funcall (get (first server-path) :server-path-parser) server-path))
101 (loop for port in *all-ports*
102 if (equal server-path (port-server-path port))
103 do (return port)
104 finally (let ((port-type (get (first server-path) :port-type))
105 port)
106 (if (null port-type)
107 (error "Don't know how to make a port of type ~S" server-path))
108 (setq port (funcall 'make-instance port-type :server-path server-path))
109 (push port *all-ports*)
110 (return port))))
111
112 (defmethod initialize-instance :after ((port basic-port) &rest args)
113 (declare (ignorable args))
114 )
115
116 (defmethod destroy-port :before ((port basic-port))
117 (when (and *multiprocessing-p* (port-event-process port))
118 (destroy-process (port-event-process port))
119 (setf (port-event-process port) nil)))
120
121 (defmethod port-lookup-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
122 (gethash sheet (slot-value port 'sheet->mirror)))
123
124 (defmethod port-lookup-sheet ((port basic-port) mirror)
125 (gethash mirror (slot-value port 'mirror->sheet)))
126
127 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
128 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
129 (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
130 nil)
131
132 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
133 (remhash sheet (slot-value port 'sheet->mirror))
134 (remhash mirror (slot-value port 'mirror->sheet))
135 nil)
136
137 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
138 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
139
140 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
141 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
142
143 (defmethod mirror-transformation ((port basic-port) mirror)
144 (declare (ignore mirror))
145 (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
146
147 (defmethod port-properties ((port basic-port) indicator)
148 (with-slots (properties) port
149 (getf properties indicator)))
150
151 (defmethod (setf port-properties) (value (port basic-port) indicator)
152 (with-slots (properties) port
153 (setf (getf properties indicator) value)))
154
155 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
156 (declare (ignore wait-function timeout))
157 (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
158
159 (defmethod get-next-event :after ((port basic-port) &key wait-function timeout)
160 (declare (ignore wait-function timeout))
161 (with-slots (event-count) port
162 (incf event-count)))
163
164 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
165 (let ((event (get-next-event port
166 :wait-function wait-function
167 :timeout timeout)))
168 (cond
169 ((null event) nil)
170 ((eq event :timeout) (values nil :timeout))
171 (t
172 (distribute-event port event)
173 t))))
174
175 (defmethod distribute-event ((port basic-port) event)
176 (cond
177 ((typep event 'keyboard-event)
178 (dispatch-event (event-sheet event) event))
179 ((typep event 'window-event)
180 ; (dispatch-event (window-event-mirrored-sheet event) event)
181 (dispatch-event (event-sheet event) event))
182 ((typep event 'pointer-event)
183 (dispatch-event (event-sheet event) event))
184 ((typep event 'window-manager-delete-event)
185 ;; not sure where this type of event should get sent - mikemac
186 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
187 (dispatch-event (event-sheet event) event))
188 ((typep event 'timer-event)
189 (error "Where do we send timer-events?"))
190 (t
191 (error "Unknown event ~S received in DISTRIBUTE-EVENT" event))))
192
193 (defmacro with-port-locked ((port) &body body)
194 (let ((fn (gensym "CONT.")))
195 `(labels ((,fn ()
196 ,@body))
197 (declare (dynamic-extent #',fn))
198 (invoke-with-port-locked ,port #',fn))))
199
200 (defmethod invoke-with-port-locked ((port basic-port) continuation)
201 (with-recursive-lock-held ((port-lock port))
202 (funcall continuation)))
203
204 (defun map-over-ports (function)
205 (mapc function *all-ports*))
206
207 (defmethod restart-port ((port basic-port))
208 (reset-watcher port :restart)
209 nil)
210
211 (defmethod destroy-port ((port basic-port))
212 (reset-watcher port :destroy))
213
214 (defmethod destroy-port :around ((port basic-port))
215 (unwind-protect
216 (call-next-method)
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"))
276
277
278 (defgeneric port-force-output (port)
279 (:documentation "Flush the output buffer of PORT, if there is one."))
280
281 (defmethod port-force-output ((port basic-port))
282 (values))
283
284 (defgeneric port-grab-pointer (port pointer sheet)
285 (:documentation "Grab the specified pointer, for implementing TRACKING-POINTER."))
286
287 (defgeneric port-ungrab-pointer (port pointer sheet)
288 (:documentation "Ungrab the specified pointer, for implementing TRACKING-POINTER."))
289
290 (defmethod port-grab-pointer ((port basic-port) pointer sheet)
291 (declare (ignorable port pointer sheet))
292 (warn "Port ~A has not implemented pointer grabbing." port))
293
294 (defmethod port-ungrab-pointer ((port basic-port) pointer sheet)
295 (declare (ignorable port pointer sheet))
296 (warn "Port ~A has not implemented pointer grabbing." port))
297
298 (defgeneric set-sheet-pointer-cursor (port sheet cursor)
299 (:documentation "Sets the cursor associated with SHEET. CURSOR is a symbol, as described in the Franz user's guide."))
300
301 (defmethod set-sheet-pointer-cursor ((port basic-port) sheet cursor)
302 (declare (ignore sheet cursor))
303 (warn "Port ~A has not implemented sheet pointer cursors." port))
304
305 ;;;;
306 ;;;; Font listing extension
307 ;;;;
308
309 (defgeneric port-all-font-families
310 (port &key invalidate-cache &allow-other-keys)
311 (:documentation
312 "Returns the list of all FONT-FAMILY instances known by PORT.
313 With INVALIDATE-CACHE, cached font family information is discarded, if any."))
314
315 (defgeneric font-family-name (font-family)
316 (:documentation
317 "Return the font family's name. This name is meant for user display,
318 and does not, at the time of this writing, necessarily the same string
319 used as the text style family for this port."))
320
321 (defgeneric font-family-port (font-family)
322 (:documentation "Return the port this font family belongs to."))
323
324 (defgeneric font-family-all-faces (font-family)
325 (:documentation
326 "Return the list of all font-face instances for this family."))
327
328 (defgeneric font-face-name (font-face)
329 (:documentation
330 "Return the font face's name. This name is meant for user display,
331 and does not, at the time of this writing, necessarily the same string
332 used as the text style face for this port."))
333
334 (defgeneric font-face-family (font-face)
335 (:documentation "Return the font family this face belongs to."))
336
337 (defgeneric font-face-all-sizes (font-face)
338 (:documentation
339 "Return the list of all font sizes known to be valid for this font,
340 if the font is restricted to particular sizes. For scalable fonts, arbitrary
341 sizes will work, and this list represents only a subset of the valid sizes.
342 See font-face-scalable-p."))
343
344 (defgeneric font-face-scalable-p (font-face)
345 (:documentation
346 "Return true if this font is scalable, as opposed to a bitmap font. For
347 a scalable font, arbitrary font sizes are expected to work."))
348
349 (defgeneric font-face-text-style (font-face &optional size)
350 (:documentation
351 "Return an extended text style describing this font face in the specified
352 size. If size is nil, the resulting text style does not specify a size."))
353
354 (defclass font-family ()
355 ((font-family-port :initarg :port :reader font-family-port)
356 (font-family-name :initarg :name :reader font-family-name))
357 (:documentation "The protocol class for font families. Each backend
358 defines a subclass of font-family and implements its accessors. Font
359 family instances are never created by user code. Use port-all-font-families
360 to list all instances available on a port."))
361
362 (defmethod print-object ((object font-family) stream)
363 (print-unreadable-object (object stream :type t :identity nil)
364 (format stream "~A" (font-family-name object))))
365
366 (defclass font-face ()
367 ((font-face-family :initarg :family :reader font-face-family)
368 (font-face-name :initarg :name :reader font-face-name))
369 (:documentation "The protocol class for font faces Each backend
370 defines a subclass of font-face and implements its accessors. Font
371 face instances are never created by user code. Use font-family-all-faces
372 to list all faces of a font family."))
373
374 (defmethod print-object ((object font-face) stream)
375 (print-unreadable-object (object stream :type t :identity nil)
376 (format stream "~A, ~A"
377 (font-family-name (font-face-family object))
378 (font-face-name object))))
379
380 ;;; fallback font listing implementation:
381
382 (defclass basic-font-family (font-family) ())
383 (defclass basic-font-face (font-face) ())
384
385 (defmethod port-all-font-families ((port basic-port) &key invalidate-cache)
386 (declare (ignore invalidate-cache))
387 (flet ((make-basic-font-family (name)
388 (make-instance 'basic-font-family :port port :name name)))
389 (list (make-basic-font-family "FIX")
390 (make-basic-font-family "SERIF")
391 (make-basic-font-family "SANS-SERIF"))))
392
393 (defmethod font-family-all-faces ((family basic-font-family))
394 (flet ((make-basic-font-face (name)
395 (make-instance 'basic-font-face :family family :name name)))
396 (list (make-basic-font-face "ROMAN")
397 (make-basic-font-face "BOLD")
398 (make-basic-font-face "BOLD-ITALIC")
399 (make-basic-font-face "ITALIC"))))
400
401 (defmethod font-face-all-sizes ((face basic-font-face))
402 (list 1 2 3 4 5 6 7))
403
404 (defmethod font-face-scalable-p ((face basic-font-face))
405 nil)
406
407 (defmethod font-face-text-style ((face basic-font-face) &optional size)
408 (make-text-style
409 (find-symbol (string-upcase (font-family-name (font-face-family face)))
410 :keyword)
411 (if (string-equal (font-face-name face) "BOLD-ITALIC")
412 '(:bold :italic)
413 (find-symbol (string-upcase (font-face-name face)) :keyword))
414 (ecase size
415 ((nil) nil)
416 (1 :tiny)
417 (2 :very-small)
418 (3 :small)
419 (4 :normal)
420 (5 :large)
421 (6 :very-large)
422 (7 :huge))))

  ViewVC Help
Powered by ViewVC 1.1.5