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)))