Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv16855/Backends/CLX

Modified Files: 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/CLX/port.lisp 2006/11/09 20:24:21 1.125 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/12/24 14:27:44 1.126 @@ -163,7 +163,8 @@ (pointer :reader port-pointer) (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil) (selection-owner :initform nil :accessor selection-owner) - (selection-timestamp :initform nil :accessor selection-timestamp))) + (selection-timestamp :initform nil :accessor selection-timestamp) + (font-families :accessor font-families)))

(defun parse-clx-server-path (path) (pop path) @@ -1434,3 +1435,95 @@ (if (streamp stream) stream (error "Cannot connect to server: ~A:~D" host display)))) + + +;;;; Font listing implementation: + +(defclass clx-font-family (clim-extensions:font-family) + ((all-faces :initform nil + :accessor all-faces + :reader clim-extensions:font-family-all-faces))) + +(defclass clx-font-face (clim-extensions:font-face) + ((all-sizes :initform nil + :accessor all-sizes + :reader clim-extensions:font-face-all-sizes))) + +(defun split-font-name (name) + (loop + repeat 12 + for next = (position #- name :start 0) + :then (position #- name :start (1+ next)) + and prev = nil then next + while next + when prev + collect (subseq name (1+ prev) next))) + +(defun reload-font-table (port) + (let ((table (make-hash-table :test 'equal))) + (dolist (font (xlib:list-font-names (clx-port-display port) "*")) + (destructuring-bind + (&optional foundry family weight slant setwidth style pixelsize + &rest ignore ;pointsize xresolution yresolution + ;spacing averagewidth registry encoding + ) + (split-font-name font) + (declare (ignore setwidth style ignore)) + (when family + (let* ((family-name (format nil "~A ~A" foundry family)) + (family-instance + (or (gethash family-name table) + (setf (gethash family-name table) + (make-instance 'clx-font-family + :port port + :name family-name)))) + (face-name (format nil "~A ~A" weight slant)) + (face-instance + (find face-name (all-faces family-instance) + :key #'clim-extensions:font-face-name + :test #'equal))) + (unless face-instance + (setf face-instance + (make-instance 'clx-font-face + :family family-instance + :name face-name)) + (push face-instance (all-faces family-instance))) + (pushnew (parse-integer + ;; FIXME: Python thinks pixelsize is NIL, resulting + ;; in a full WARNING. Let's COERCE to make it work. + (coerce pixelsize 'string)) + (all-sizes face-instance)))))) + (setf (font-families port) + (sort (loop + for family being each hash-value in table + do + (setf (all-faces family) + (sort (all-faces family) + #'string< + :key #'clim-extensions:font-face-name)) + (dolist (face (all-faces family)) + (setf (all-sizes face) (sort (all-sizes face) #'<))) + collect family) + #'string< + :key #'clim-extensions:font-family-name)))) + +(defmethod clim-extensions:port-all-font-families + ((port clx-port) &key invalidate-cache) + (when (or (not (slot-boundp port 'font-families)) invalidate-cache) + (reload-font-table port)) + (font-families port)) + +(defmethod clim-extensions:font-face-scalable-p ((face clx-font-face)) + nil) + +(defun make-unfriendly-name (str) + (substitute #- #\space str)) + +(defmethod clim-extensions:font-face-text-style + ((face clx-font-face) &optional size) + (make-text-style (make-unfriendly-name + (clim-extensions:font-family-name + (clim-extensions:font-face-family face))) + (make-unfriendly-name + (clim-extensions:font-face-name face)) + size))