[mcclim-cvs] CVS mcclim/Backends/gtkairo
dlichteblau
dlichteblau at common-lisp.net
Sun Dec 24 14:27:48 UTC 2006
Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo
In directory clnet:/tmp/cvs-serv16855/Backends/gtkairo
Modified Files:
ffi.lisp pango.lisp port.lisp
Log Message:
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.
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/24 11:30:59 1.12
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/12/24 14:27:45 1.13
@@ -1498,6 +1498,18 @@
(desc :pointer) ;const PangoFontDescription *
)
+(defcfun "pango_font_face_get_face_name"
+ :string
+ (face :pointer) ;PangoFontFace *
+ )
+
+(defcfun "pango_font_face_list_sizes"
+ :void
+ (face :pointer) ;PangoFontFace *
+ (sizes :pointer) ;int **
+ (n_sizes :pointer) ;int *
+ )
+
(defcfun "pango_font_family_get_name"
:string
(family :pointer) ;PangoFontFamily *
@@ -1508,6 +1520,13 @@
(family :pointer) ;PangoFontFamily *
)
+(defcfun "pango_font_family_list_faces"
+ :void
+ (family :pointer) ;PangoFontFamily *
+ (faces :pointer) ;PangoFontFace ***
+ (n_faces :pointer) ;int *
+ )
+
(defcfun "pango_font_map_load_font"
:pointer
(fontmap :pointer) ;PangoFontMap *
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/23 13:26:54 1.2
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/pango.lisp 2006/12/24 14:27:45 1.3
@@ -123,23 +123,11 @@
(symbol-name (first face))
(symbol-name (second face)))
:keyword)))
- (let ((desc (pango_font_description_new))
- (family (or (getf *default-font-families*
- (if (eq family :fixed) :fix family))
- (error "unknown font family: ~A" family)))
- (weight (ecase face
- ((:roman :italic :oblique)
- :PANGO_WEIGHT_NORMAL)
- ((:bold :bold-italic :italic-bold :bold-oblique
- :oblique-bold)
- :PANGO_WEIGHT_BOLD)))
- (style (ecase face
- ((:roman :bold)
- :PANGO_STYLE_NORMAL)
- ((:italic :bold-italic :italic-bold)
- :PANGO_STYLE_ITALIC)
- ((:oblique :bold-oblique :oblique-bold)
- :PANGO_STYLE_OBLIQUE)))
+ (let ((family (if (stringp family)
+ family
+ (or (getf *default-font-families*
+ (if (eq family :fixed) :fix family))
+ (error "unknown font family: ~A" family))))
(size (case size
(:normal 12)
(:tiny 6)
@@ -148,10 +136,28 @@
(:large 14)
(:very-large 16)
(:huge 24)
- (otherwise (truncate size)))))
+ (otherwise (truncate size))))
+ desc)
+ (if (stringp face)
+ (setf desc (pango_font_description_from_string
+ (concatenate 'string ", " face)))
+ (let ((weight (ecase face
+ ((:roman :italic :oblique)
+ :PANGO_WEIGHT_NORMAL)
+ ((:bold :bold-italic :italic-bold :bold-oblique
+ :oblique-bold)
+ :PANGO_WEIGHT_BOLD)))
+ (style (ecase face
+ ((:roman :bold)
+ :PANGO_STYLE_NORMAL)
+ ((:italic :bold-italic :italic-bold)
+ :PANGO_STYLE_ITALIC)
+ ((:oblique :bold-oblique :oblique-bold)
+ :PANGO_STYLE_OBLIQUE))))
+ (setf desc (pango_font_description_new))
+ (pango_font_description_set_weight desc weight)
+ (pango_font_description_set_style desc style)))
(pango_font_description_set_family desc family)
- (pango_font_description_set_weight desc weight)
- (pango_font_description_set_style desc style)
(pango_font_description_set_size desc (* size PANGO_SCALE))
desc)))
@@ -242,17 +248,6 @@
;; (pango_layout_get_context layout)
-(defun pango-context-list-families (context)
- (cffi:with-foreign-object (&families :pointer)
- (cffi:with-foreign-object (&n :int)
- (pango_context_list_families context &families &n)
- (let ((families (cffi:mem-aref &families :pointer)))
- (prog1
- (loop
- for i from 0 below (cffi:mem-aref &n :int)
- collect (cffi:mem-aref families :pointer i))
- (g_free families))))))
-
(defun resolve-font-description (context desc)
(pango_font_describe (pango_context_load_font context desc)))
@@ -308,3 +303,81 @@
(with-font-metrics (metrics context desc)
(ceiling (pango_font_metrics_get_approximate_char_width metrics)
PANGO_SCALE))))))
+
+
+;; font listing
+
+(defclass pango-font-family (clim-extensions:font-family)
+ ((native-family :initarg :native-family :accessor native-family)))
+
+(defclass pango-font-face (clim-extensions:font-face)
+ ((native-face :initarg :native-face :accessor native-face)))
+
+(defun invoke-lister (fn type)
+ (cffi:with-foreign-object (&array :pointer)
+ (cffi:with-foreign-object (&n :int)
+ (funcall fn &array &n)
+ (let ((array (cffi:mem-aref &array :pointer)))
+ (if (cffi:null-pointer-p array)
+ :null
+ (prog1
+ (loop
+ for i from 0 below (cffi:mem-aref &n :int)
+ collect (cffi:mem-aref array type i))
+ (g_free array)))))))
+
+(defun pango-context-list-families (context)
+ (invoke-lister (lambda (&families &n)
+ (pango_context_list_families context &families &n))
+ :pointer))
+
+(defun pango-font-family-list-faces (family)
+ (invoke-lister (lambda (&faces &n)
+ (pango_font_family_list_faces family &faces &n))
+ :pointer))
+
+(defun pango-font-face-list-sizes (face)
+ (invoke-lister (lambda (&sizes &n)
+ (pango_font_face_list_sizes face &sizes &n))
+ :int))
+
+(defmethod clim-extensions:port-all-font-families
+ ((port gtkairo-port) &key invalidate-cache)
+ (declare (ignore invalidate-cache))
+ (sort (mapcar (lambda (native-family)
+ (make-instance 'pango-font-family
+ :native-family native-family
+ :port port
+ :name (pango_font_family_get_name native-family)))
+ (pango-context-list-families (global-pango-context port)))
+ #'string<
+ :key #'clim-extensions:font-family-name))
+
+(defmethod clim-extensions:font-family-all-faces ((family pango-font-family))
+ (sort (mapcar (lambda (native-face)
+ (make-instance 'pango-font-face
+ :native-face native-face
+ :family family
+ :name (pango_font_face_get_face_name native-face)))
+ (pango-font-family-list-faces (native-family family)))
+ #'string<
+ :key #'clim-extensions:font-face-name))
+
+(defmethod clim-extensions:font-face-all-sizes ((face pango-font-face))
+ (let ((sizes (pango-font-face-list-sizes (native-face face))))
+ (if (eq sizes :null)
+ (loop for i from 0 below 200 collect i)
+ (mapcar (lambda (p)
+ ;; das mit dem round kommt mir aber nicht koscher vor
+ (round (/ p PANGO_SCALE)))
+ sizes))))
+
+(defmethod clim-extensions:font-face-scalable-p ((face pango-font-face))
+ (eq :null (pango-font-face-list-sizes (native-face face))))
+
+(defmethod clim-extensions:font-face-text-style
+ ((face pango-font-face) &optional size)
+ (make-text-style (clim-extensions:font-family-name
+ (clim-extensions:font-face-family face))
+ (clim-extensions:font-face-name face)
+ size))
--- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/12/03 15:24:09 1.12
+++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/12/24 14:27:45 1.13
@@ -49,7 +49,8 @@
(widgets->sheets :initform (make-hash-table) :accessor widgets->sheets)
(dirty-mediums :initform (make-hash-table) :accessor dirty-mediums)
(metrik-medium :accessor metrik-medium)
- (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil)))
+ (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil)
+ (global-pango-context :accessor global-pango-context)))
;;;(defmethod print-object ((object gtkairo-port) stream)
;;; (print-unreadable-object (object stream :identity t :type t)
@@ -85,7 +86,8 @@
(gdk_screen_get_root_window (gdk_screen_get_default)))))
(set-antialias cr)
(setf (metrik-medium port)
- (make-instance 'metrik-medium :port port :cr cr))))
+ (make-instance 'metrik-medium :port port :cr cr)))
+ (setf (global-pango-context port) (gdk_pango_context_get)))
(when clim-sys:*multiprocessing-p*
(start-event-thread port)))
More information about the Mcclim-cvs
mailing list