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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.56 - (hide 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 mikemac 1.1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2    
3 mikemac 1.19 ;;; (c) copyright 1998,1999,2000,2001 by Michael McDonald (mikemac@mikemac.com)
4 cvs 1.5 ;;; (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 mikemac 1.1
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 mikemac 1.38 (in-package :clim-internals)
25 mikemac 1.1
26 mikemac 1.39 (defvar *default-server-path* nil)
27 mikemac 1.22
28 dlichteblau 1.56 ;; - 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 mikemac 1.22
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 mikemac 1.1
47     (defvar *all-ports* nil)
48    
49 gilbert 1.21 (defclass basic-port (port)
50 mikemac 1.1 ((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 cvs 1.10 (pixmap->mirror :initform (make-hash-table :test #'eq))
62     (mirror->pixmap :initform (make-hash-table :test #'eq))
63 gilbert 1.21 (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 adejneka 1.34
70 gilbert 1.21 (lock
71     :initform (make-recursive-lock "port lock")
72 mikemac 1.25 :accessor port-lock)
73     (event-count :initform 0)
74 adejneka 1.34 (text-style-mappings :initform (make-hash-table :test #'eq)
75     :reader port-text-style-mappings)
76 moore 1.36 (pointer-sheet :initform nil :accessor port-pointer-sheet
77 crhodes 1.55 :documentation "The sheet the pointer is over, if any")))
78 rstrandh 1.49
79 hefner1 1.40 (defmethod port-keyboard-input-focus (port)
80 crhodes 1.55 (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 hefner1 1.40
92 crhodes 1.55 (defgeneric port-frame-keyboard-input-focus (port frame))
93     (defgeneric (setf port-frame-keyboard-input-focus) (focus port frame))
94 hefner1 1.40
95 mikemac 1.1 (defun find-port (&key (server-path *default-server-path*))
96 mikemac 1.22 (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 mikemac 1.1 (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 gilbert 1.21 (defmethod initialize-instance :after ((port basic-port) &rest args)
113     (declare (ignorable args))
114     )
115    
116     (defmethod destroy-port :before ((port basic-port))
117 adejneka 1.33 (when (and *multiprocessing-p* (port-event-process port))
118 gilbert 1.21 (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 mikemac 1.1 (gethash sheet (slot-value port 'sheet->mirror)))
123    
124 gilbert 1.21 (defmethod port-lookup-sheet ((port basic-port) mirror)
125 mikemac 1.1 (gethash mirror (slot-value port 'mirror->sheet)))
126    
127 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
128 mikemac 1.1 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
129     (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
130     nil)
131    
132 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
133 mikemac 1.1 (remhash sheet (slot-value port 'sheet->mirror))
134     (remhash mirror (slot-value port 'mirror->sheet))
135     nil)
136    
137 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
138 mikemac 1.1 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
139    
140 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
141 rouanet 1.15 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
142 mikemac 1.1
143 gilbert 1.21 (defmethod mirror-transformation ((port basic-port) mirror)
144 rouanet 1.16 (declare (ignore mirror))
145     (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
146    
147 gilbert 1.21 (defmethod port-properties ((port basic-port) indicator)
148 mikemac 1.1 (with-slots (properties) port
149     (getf properties indicator)))
150    
151 gilbert 1.21 (defmethod (setf port-properties) (value (port basic-port) indicator)
152 mikemac 1.1 (with-slots (properties) port
153     (setf (getf properties indicator) value)))
154    
155 gilbert 1.21 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
156 mikemac 1.1 (declare (ignore wait-function timeout))
157     (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
158    
159 mikemac 1.25 (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 gilbert 1.21 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
165 moore 1.26 (let ((event (get-next-event port
166     :wait-function wait-function
167     :timeout timeout)))
168 mikemac 1.1 (cond
169     ((null event) nil)
170     ((eq event :timeout) (values nil :timeout))
171     (t
172 moore 1.27 (distribute-event port event)
173 mikemac 1.1 t))))
174    
175 gilbert 1.21 (defmethod distribute-event ((port basic-port) event)
176 mikemac 1.1 (cond
177     ((typep event 'keyboard-event)
178 crhodes 1.55 (dispatch-event (event-sheet event) event))
179 mikemac 1.1 ((typep event 'window-event)
180 brian 1.28 ; (dispatch-event (window-event-mirrored-sheet event) event)
181 cvs 1.4 (dispatch-event (event-sheet event) event))
182 mikemac 1.1 ((typep event 'pointer-event)
183     (dispatch-event (event-sheet event) event))
184 mikemac 1.23 ((typep event 'window-manager-delete-event)
185     ;; not sure where this type of event should get sent - mikemac
186 moore 1.27 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
187     (dispatch-event (event-sheet event) event))
188 mikemac 1.1 ((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 gilbert 1.21 (defmacro with-port-locked ((port) &body body)
194     (let ((fn (gensym "CONT.")))
195     `(labels ((,fn ()
196     ,@body))
197     (declare (dynamic-extent #',fn))
198 moore 1.29 (invoke-with-port-locked ,port #',fn))))
199 gilbert 1.21
200     (defmethod invoke-with-port-locked ((port basic-port) continuation)
201     (with-recursive-lock-held ((port-lock port))
202     (funcall continuation)))
203    
204 mikemac 1.1 (defun map-over-ports (function)
205     (mapc function *all-ports*))
206    
207 gilbert 1.21 (defmethod restart-port ((port basic-port))
208 mikemac 1.1 (reset-watcher port :restart)
209     nil)
210    
211 gilbert 1.21 (defmethod destroy-port ((port basic-port))
212 ahefner 1.53 (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 mikemac 1.1
219 gilbert 1.21 (defmethod add-watcher ((port basic-port) watcher)
220 mikemac 1.1 (declare (ignore watcher))
221     nil)
222    
223 gilbert 1.21 (defmethod delete-watcher ((port basic-port) watcher)
224 mikemac 1.1 (declare (ignore watcher))
225     nil)
226    
227 gilbert 1.21 (defmethod reset-watcher ((port basic-port) how)
228 mikemac 1.1 (declare (ignore how))
229     nil)
230    
231 gilbert 1.21 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
232 mikemac 1.1 (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 gilbert 1.21 #||
239     (defmethod make-medium ((port basic-port) sheet)
240 rouanet 1.16 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
241 gilbert 1.21 ||#
242 mikemac 1.1
243 cvs 1.10 ;;; Pixmap
244    
245 gilbert 1.21 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
246 cvs 1.10 (gethash pixmap (slot-value port 'pixmap->mirror)))
247    
248 gilbert 1.21 (defmethod port-lookup-pixmap ((port basic-port) mirror)
249 cvs 1.10 (gethash mirror (slot-value port 'mirror->pixmap)))
250    
251 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
252 cvs 1.10 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
253     (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
254     nil)
255    
256 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
257 cvs 1.10 (remhash pixmap (slot-value port 'pixmap->mirror))
258     (remhash mirror (slot-value port 'mirror->pixmap))
259     nil)
260    
261 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
262 cvs 1.10 (declare (ignorable port pixmap))
263     (error "Don't know how to realize the mirror on a generic port"))
264    
265 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
266 cvs 1.10 (declare (ignorable port pixmap))
267 rouanet 1.15 (error "Don't know how to destroy the mirror on a generic port"))
268 cvs 1.10
269 gilbert 1.21 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
270 mikemac 1.1 (declare (ignore sheet width height))
271 cvs 1.10 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
272 mikemac 1.1
273 gilbert 1.21 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
274 mikemac 1.1 (declare (ignore pixmap))
275 cvs 1.10 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))
276 hefner1 1.42
277    
278 hefner1 1.43 (defgeneric port-force-output (port)
279     (:documentation "Flush the output buffer of PORT, if there is one."))
280 hefner1 1.42
281     (defmethod port-force-output ((port basic-port))
282     (values))
283 hefner1 1.43
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 hefner1 1.44 (defmethod port-grab-pointer ((port basic-port) pointer sheet)
291 hefner1 1.43 (declare (ignorable port pointer sheet))
292     (warn "Port ~A has not implemented pointer grabbing." port))
293    
294 hefner1 1.44 (defmethod port-ungrab-pointer ((port basic-port) pointer sheet)
295 hefner1 1.43 (declare (ignorable port pointer sheet))
296     (warn "Port ~A has not implemented pointer grabbing." port))
297    
298 hefner1 1.44 (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 moore 1.46 (declare (ignore sheet cursor))
303 hefner1 1.44 (warn "Port ~A has not implemented sheet pointer cursors." port))
304 dlichteblau 1.54
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