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

Contents of /mcclim/ports.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.54 - (hide annotations)
Sun Dec 24 14:27:43 2006 UTC (7 years, 3 months ago) by dlichteblau
Branch: MAIN
CVS Tags: mcclim-0-9-4, McCLIM-0-9-4
Changes since 1.53: +119 -0 lines
Enable support for extended text styles using strings for family and face,
as already implemented in CLIM-CLX.  Teach Gtkairo do the same.

Add an API for font listing (implemented in CLX and Gtkairo, plus a
trivial fallback implementation for other backends) and a font selection
dialog as an example.

	* Doc/mcclim.texi: New chapter "Fonts and Extended Text Styles"

	* Examples/font-selector.lisp: New file.

	* Examples/demodemo.lisp: Added a button for the font selector.

	* mcclim.asd (CLIM-EXAMPLES): Added font-selector.lisp.

	* package.lisp (CLIM-EXTENSIONS): Export new symbols font-family
	font-face port-all-font-families font-family-name font-family-port
	font-family-all-faces font-face-name font-face-family
	font-face-all-sizes font-face-scalable-p font-face-text-style.

	* medium.lisp (MAKE-TEXT-STYLE, TEXT-STYLE-EQUALP): Allow strings
	for family and face.  (MAKE-TEXT-STYLE-1): New helper function.

	* ports.lisp (FONT-FAMILY, FONT-FACE): New classes.
	(port-all-font-families font-family-name font-family-port
	font-family-all-faces font-face-name font-face-family
	font-face-all-sizes font-face-scalable-p font-face-text-style):
	New generic functions and default methods.

	* Backends/CLX/port.lisp (FONT-FAMILIES): New slot in the port.
	(CLX-FONT-FAMILY, CLX-FONT-FACE): New classes.
	(port-all-font-families font-family-name font-family-port
	font-family-all-faces font-face-name font-face-family
	font-face-all-sizes font-face-scalable-p font-face-text-style):
	New methods. (SPLIT-FONT-NAME, RELOAD-FONT-TABLE,
	MAKE-UNFRIEDLY-NAME): New helper functions.

	* Backends/gtkairo/pango.lisp (MAKE-FONT-DESCRIPTION): Support
	strings for family and face.
	(PANGO-FONT-FAMILY, PANGO-FONT-FACE): New classes.
	(port-all-font-families font-family-name font-family-port
	font-family-all-faces font-face-name font-face-family
	font-face-all-sizes font-face-scalable-p font-face-text-style):
	New methods. (INVOKE-LISTER, pango-font-family-list-faces,
	pango-font-face-list-sizes): New helper functions.

	* Backends/gtkairo/port.lisp (GLOBAL-PANGO-CONTEXT): New slot in
	the port.  ((INITIALIZE-INSTANCE GTKAIRO-PORT)): Set the pango
	context.

	* Backends/gtkairo/ffi.lisp: regenerated.
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.52 (defvar *server-path-search-order* '(:genera :ms-windows :gtkairo :clx :x11 :opengl :beagle :null))
29 mikemac 1.22
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 mikemac 1.1
36     (defvar *all-ports* nil)
37    
38 gilbert 1.21 (defclass basic-port (port)
39 mikemac 1.1 ((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 cvs 1.10 (pixmap->mirror :initform (make-hash-table :test #'eq))
51     (mirror->pixmap :initform (make-hash-table :test #'eq))
52 hefner1 1.40 #+ignore (keyboard-input-focus :initform nil ;; nuked this, see below
53 mikemac 1.1 :initarg :keyboard-input-focus
54     :accessor port-keyboard-input-focus)
55 gilbert 1.21 (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 adejneka 1.34
62 gilbert 1.21 (lock
63     :initform (make-recursive-lock "port lock")
64 mikemac 1.25 :accessor port-lock)
65     (event-count :initform 0)
66 adejneka 1.34 (text-style-mappings :initform (make-hash-table :test #'eq)
67     :reader port-text-style-mappings)
68 moore 1.36 (pointer-sheet :initform nil :accessor port-pointer-sheet
69     :documentation "The sheet the pointer is over, if any")
70 mikemac 1.25 ))
71 mikemac 1.1
72 hefner1 1.40 ;; Keyboard focus is now managed per-frame rather than per-port,
73 ahefner 1.48 ;; 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 rstrandh 1.49 (defgeneric port-keyboard-input-focus (port))
94     (defgeneric (setf port-keyboard-input-focus) (focus port))
95    
96 hefner1 1.40 (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 hefner1 1.41 (when focus
103     (if (pane-frame focus)
104     (setf (keyboard-input-focus (pane-frame focus)) focus)
105 ahefner 1.48 (%set-port-keyboard-focus port focus))))
106 hefner1 1.41
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 ahefner 1.48 (defmethod %set-port-keyboard-focus (port focus &key timestamp)
111 rstrandh 1.49 (declare (ignore focus timestamp))
112 ahefner 1.48 (warn "%SET-PORT-KEYBOARD-FOCUS is not implemented on ~W" port))
113 hefner1 1.41
114 hefner1 1.40
115 mikemac 1.1 (defun find-port (&key (server-path *default-server-path*))
116 mikemac 1.22 (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 mikemac 1.1 (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 gilbert 1.21 (defmethod initialize-instance :after ((port basic-port) &rest args)
133     (declare (ignorable args))
134     )
135    
136     (defmethod destroy-port :before ((port basic-port))
137 adejneka 1.33 (when (and *multiprocessing-p* (port-event-process port))
138 gilbert 1.21 (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 mikemac 1.1 (gethash sheet (slot-value port 'sheet->mirror)))
143    
144 gilbert 1.21 (defmethod port-lookup-sheet ((port basic-port) mirror)
145 mikemac 1.1 (gethash mirror (slot-value port 'mirror->sheet)))
146    
147 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
148 mikemac 1.1 (setf (gethash sheet (slot-value port 'sheet->mirror)) mirror)
149     (setf (gethash mirror (slot-value port 'mirror->sheet)) sheet)
150     nil)
151    
152 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (sheet mirrored-sheet-mixin) mirror)
153 mikemac 1.1 (remhash sheet (slot-value port 'sheet->mirror))
154     (remhash mirror (slot-value port 'mirror->sheet))
155     nil)
156    
157 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
158 mikemac 1.1 (error "Don't know how to realize the mirror of a generic mirrored-sheet"))
159    
160 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (sheet mirrored-sheet-mixin))
161 rouanet 1.15 (error "Don't know how to destroy the mirror of a generic mirrored-sheet"))
162 mikemac 1.1
163 gilbert 1.21 (defmethod mirror-transformation ((port basic-port) mirror)
164 rouanet 1.16 (declare (ignore mirror))
165     (error "MIRROR-TRANSFORMATION is not implemented for generic ports"))
166    
167 gilbert 1.21 (defmethod port-properties ((port basic-port) indicator)
168 mikemac 1.1 (with-slots (properties) port
169     (getf properties indicator)))
170    
171 gilbert 1.21 (defmethod (setf port-properties) (value (port basic-port) indicator)
172 mikemac 1.1 (with-slots (properties) port
173     (setf (getf properties indicator) value)))
174    
175 gilbert 1.21 (defmethod get-next-event ((port basic-port) &key wait-function timeout)
176 mikemac 1.1 (declare (ignore wait-function timeout))
177     (error "Calling GET-NEXT-EVENT on a PORT protocol class"))
178    
179 mikemac 1.25 (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 gilbert 1.21 (defmethod process-next-event ((port basic-port) &key wait-function timeout)
185 moore 1.26 (let ((event (get-next-event port
186     :wait-function wait-function
187     :timeout timeout)))
188 mikemac 1.1 (cond
189     ((null event) nil)
190     ((eq event :timeout) (values nil :timeout))
191     (t
192 moore 1.27 (distribute-event port event)
193 mikemac 1.1 t))))
194    
195 gilbert 1.21 (defmethod distribute-event ((port basic-port) event)
196 mikemac 1.1 (cond
197     ((typep event 'keyboard-event)
198 hefner1 1.40 (dispatch-event (or #+ignore(port-keyboard-input-focus port) (event-sheet event))
199 moore 1.35 event))
200 mikemac 1.1 ((typep event 'window-event)
201 brian 1.28 ; (dispatch-event (window-event-mirrored-sheet event) event)
202 cvs 1.4 (dispatch-event (event-sheet event) event))
203 mikemac 1.1 ((typep event 'pointer-event)
204     (dispatch-event (event-sheet event) event))
205 mikemac 1.23 ((typep event 'window-manager-delete-event)
206     ;; not sure where this type of event should get sent - mikemac
207 moore 1.27 ;; This seems fine; will be handled by the top-level-sheet-pane - moore
208     (dispatch-event (event-sheet event) event))
209 mikemac 1.1 ((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 gilbert 1.21 (defmacro with-port-locked ((port) &body body)
215     (let ((fn (gensym "CONT.")))
216     `(labels ((,fn ()
217     ,@body))
218     (declare (dynamic-extent #',fn))
219 moore 1.29 (invoke-with-port-locked ,port #',fn))))
220 gilbert 1.21
221     (defmethod invoke-with-port-locked ((port basic-port) continuation)
222     (with-recursive-lock-held ((port-lock port))
223     (funcall continuation)))
224    
225 mikemac 1.1 (defun map-over-ports (function)
226     (mapc function *all-ports*))
227    
228 gilbert 1.21 (defmethod restart-port ((port basic-port))
229 mikemac 1.1 (reset-watcher port :restart)
230     nil)
231    
232 gilbert 1.21 (defmethod destroy-port ((port basic-port))
233 ahefner 1.53 (reset-watcher port :destroy))
234    
235     (defmethod destroy-port :around ((port basic-port))
236     (unwind-protect
237     (call-next-method)
238     (setf *all-ports* (remove port *all-ports*))))
239 mikemac 1.1
240 gilbert 1.21 (defmethod add-watcher ((port basic-port) watcher)
241 mikemac 1.1 (declare (ignore watcher))
242     nil)
243    
244 gilbert 1.21 (defmethod delete-watcher ((port basic-port) watcher)
245 mikemac 1.1 (declare (ignore watcher))
246     nil)
247    
248 gilbert 1.21 (defmethod reset-watcher ((port basic-port) how)
249 mikemac 1.1 (declare (ignore how))
250     nil)
251    
252 gilbert 1.21 (defmethod make-graft ((port basic-port) &key (orientation :default) (units :device))
253 mikemac 1.1 (let ((graft (make-instance 'graft
254     :port port :mirror nil
255     :orientation orientation :units units)))
256     (push graft (port-grafts port))
257     graft))
258    
259 gilbert 1.21 #||
260     (defmethod make-medium ((port basic-port) sheet)
261 rouanet 1.16 (make-instance 'basic-medium :port port :graft (graft sheet) :sheet sheet))
262 gilbert 1.21 ||#
263 mikemac 1.1
264 cvs 1.10 ;;; Pixmap
265    
266 gilbert 1.21 (defmethod port-lookup-mirror ((port basic-port) (pixmap pixmap))
267 cvs 1.10 (gethash pixmap (slot-value port 'pixmap->mirror)))
268    
269 gilbert 1.21 (defmethod port-lookup-pixmap ((port basic-port) mirror)
270 cvs 1.10 (gethash mirror (slot-value port 'mirror->pixmap)))
271    
272 gilbert 1.21 (defmethod port-register-mirror ((port basic-port) (pixmap pixmap) mirror)
273 cvs 1.10 (setf (gethash pixmap (slot-value port 'pixmap->mirror)) mirror)
274     (setf (gethash mirror (slot-value port 'mirror->pixmap)) pixmap)
275     nil)
276    
277 gilbert 1.21 (defmethod port-unregister-mirror ((port basic-port) (pixmap pixmap) mirror)
278 cvs 1.10 (remhash pixmap (slot-value port 'pixmap->mirror))
279     (remhash mirror (slot-value port 'mirror->pixmap))
280     nil)
281    
282 gilbert 1.21 (defmethod realize-mirror ((port basic-port) (pixmap mirrored-pixmap))
283 cvs 1.10 (declare (ignorable port pixmap))
284     (error "Don't know how to realize the mirror on a generic port"))
285    
286 gilbert 1.21 (defmethod destroy-mirror ((port basic-port) (pixmap mirrored-pixmap))
287 cvs 1.10 (declare (ignorable port pixmap))
288 rouanet 1.15 (error "Don't know how to destroy the mirror on a generic port"))
289 cvs 1.10
290 gilbert 1.21 (defmethod port-allocate-pixmap ((port basic-port) sheet width height)
291 mikemac 1.1 (declare (ignore sheet width height))
292 cvs 1.10 (error "ALLOCATE-PIXMAP is not implemented for generic PORTs"))
293 mikemac 1.1
294 gilbert 1.21 (defmethod port-deallocate-pixmap ((port basic-port) pixmap)
295 mikemac 1.1 (declare (ignore pixmap))
296 cvs 1.10 (error "DEALLOCATE-PIXMAP is not implemented for generic PORTs"))
297 hefner1 1.42
298    
299 hefner1 1.43 (defgeneric port-force-output (port)
300     (:documentation "Flush the output buffer of PORT, if there is one."))
301 hefner1 1.42
302     (defmethod port-force-output ((port basic-port))
303     (values))
304 hefner1 1.43
305     (defgeneric port-grab-pointer (port pointer sheet)
306     (:documentation "Grab the specified pointer, for implementing TRACKING-POINTER."))
307    
308     (defgeneric port-ungrab-pointer (port pointer sheet)
309     (:documentation "Ungrab the specified pointer, for implementing TRACKING-POINTER."))
310    
311 hefner1 1.44 (defmethod port-grab-pointer ((port basic-port) pointer sheet)
312 hefner1 1.43 (declare (ignorable port pointer sheet))
313     (warn "Port ~A has not implemented pointer grabbing." port))
314    
315 hefner1 1.44 (defmethod port-ungrab-pointer ((port basic-port) pointer sheet)
316 hefner1 1.43 (declare (ignorable port pointer sheet))
317     (warn "Port ~A has not implemented pointer grabbing." port))
318    
319 hefner1 1.44 (defgeneric set-sheet-pointer-cursor (port sheet cursor)
320     (:documentation "Sets the cursor associated with SHEET. CURSOR is a symbol, as described in the Franz user's guide."))
321    
322     (defmethod set-sheet-pointer-cursor ((port basic-port) sheet cursor)
323 moore 1.46 (declare (ignore sheet cursor))
324 hefner1 1.44 (warn "Port ~A has not implemented sheet pointer cursors." port))
325 dlichteblau 1.54
326     ;;;;
327     ;;;; Font listing extension
328     ;;;;
329    
330     (defgeneric port-all-font-families
331     (port &key invalidate-cache &allow-other-keys)
332     (:documentation
333     "Returns the list of all FONT-FAMILY instances known by PORT.
334     With INVALIDATE-CACHE, cached font family information is discarded, if any."))
335    
336     (defgeneric font-family-name (font-family)
337     (:documentation
338     "Return the font family's name. This name is meant for user display,
339     and does not, at the time of this writing, necessarily the same string
340     used as the text style family for this port."))
341    
342     (defgeneric font-family-port (font-family)
343     (:documentation "Return the port this font family belongs to."))
344    
345     (defgeneric font-family-all-faces (font-family)
346     (:documentation
347     "Return the list of all font-face instances for this family."))
348    
349     (defgeneric font-face-name (font-face)
350     (:documentation
351     "Return the font face's name. This name is meant for user display,
352     and does not, at the time of this writing, necessarily the same string
353     used as the text style face for this port."))
354    
355     (defgeneric font-face-family (font-face)
356     (:documentation "Return the font family this face belongs to."))
357    
358     (defgeneric font-face-all-sizes (font-face)
359     (:documentation
360     "Return the list of all font sizes known to be valid for this font,
361     if the font is restricted to particular sizes. For scalable fonts, arbitrary
362     sizes will work, and this list represents only a subset of the valid sizes.
363     See font-face-scalable-p."))
364    
365     (defgeneric font-face-scalable-p (font-face)
366     (:documentation
367     "Return true if this font is scalable, as opposed to a bitmap font. For
368     a scalable font, arbitrary font sizes are expected to work."))
369    
370     (defgeneric font-face-text-style (font-face &optional size)
371     (:documentation
372     "Return an extended text style describing this font face in the specified
373     size. If size is nil, the resulting text style does not specify a size."))
374    
375     (defclass font-family ()
376     ((font-family-port :initarg :port :reader font-family-port)
377     (font-family-name :initarg :name :reader font-family-name))
378     (:documentation "The protocol class for font families. Each backend
379     defines a subclass of font-family and implements its accessors. Font
380     family instances are never created by user code. Use port-all-font-families
381     to list all instances available on a port."))
382    
383     (defmethod print-object ((object font-family) stream)
384     (print-unreadable-object (object stream :type t :identity nil)
385     (format stream "~A" (font-family-name object))))
386    
387     (defclass font-face ()
388     ((font-face-family :initarg :family :reader font-face-family)
389     (font-face-name :initarg :name :reader font-face-name))
390     (:documentation "The protocol class for font faces Each backend
391     defines a subclass of font-face and implements its accessors. Font
392     face instances are never created by user code. Use font-family-all-faces
393     to list all faces of a font family."))
394    
395     (defmethod print-object ((object font-face) stream)
396     (print-unreadable-object (object stream :type t :identity nil)
397     (format stream "~A, ~A"
398     (font-family-name (font-face-family object))
399     (font-face-name object))))
400    
401     ;;; fallback font listing implementation:
402    
403     (defclass basic-font-family (font-family) ())
404     (defclass basic-font-face (font-face) ())
405    
406     (defmethod port-all-font-families ((port basic-port) &key invalidate-cache)
407     (declare (ignore invalidate-cache))
408     (flet ((make-basic-font-family (name)
409     (make-instance 'basic-font-family :port port :name name)))
410     (list (make-basic-font-family "FIX")
411     (make-basic-font-family "SERIF")
412     (make-basic-font-family "SANS-SERIF"))))
413    
414     (defmethod font-family-all-faces ((family basic-font-family))
415     (flet ((make-basic-font-face (name)
416     (make-instance 'basic-font-face :family family :name name)))
417     (list (make-basic-font-face "ROMAN")
418     (make-basic-font-face "BOLD")
419     (make-basic-font-face "BOLD-ITALIC")
420     (make-basic-font-face "ITALIC"))))
421    
422     (defmethod font-face-all-sizes ((face basic-font-face))
423     (list 1 2 3 4 5 6 7))
424    
425     (defmethod font-face-scalable-p ((face basic-font-face))
426     nil)
427    
428     (defmethod font-face-text-style ((face basic-font-face) &optional size)
429     (make-text-style
430     (find-symbol (string-upcase (font-family-name (font-face-family face)))
431     :keyword)
432     (if (string-equal (font-face-name face) "BOLD-ITALIC")
433     '(:bold :italic)
434     (find-symbol (string-upcase (font-face-name face)) :keyword))
435     (ecase size
436     ((nil) nil)
437     (1 :tiny)
438     (2 :very-small)
439     (3 :small)
440     (4 :normal)
441     (5 :large)
442     (6 :very-large)
443     (7 :huge))))

  ViewVC Help
Powered by ViewVC 1.1.5