[mcclim-cvs] CVS mcclim/Backends/CLX

[dlichteblau]

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