Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv14215

Modified Files: freetype-fonts.lisp mcclim-freetype.asd Added Files: fontconfig.lisp Log Message: Now that everything is working fairly reliably, break it all by changing how the font path is configured. Call fc-match for each possible family/face combination, and build the map from that, allowing fontconfig to do what it is designed for. In this way, systems using DejaVu instead of Vera work automatically, and changing the default font choices require just changing one font name rather than four filenames. Via the magic of merge-pathnames, the old approach of a relative mapping and *freetype-font-path* still works.

--- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/15 09:06:52 1.18 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/17 07:57:55 1.19 @@ -6,6 +6,7 @@ ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2003 by Gilbert Baumann +;;; (c) copyright 2008 by Andy Hefner

;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -177,7 +178,6 @@ (glyph-info glyph-id dx dy left right top)))))

;;;;;;; mcclim interface - (defclass freetype-face () ((display :initarg :display :reader freetype-face-display) (font :initarg :font :reader freetype-face-name) @@ -367,7 +367,7 @@ :very-large 18 :huge 24))

-(defparameter *families/faces* +(defparameter *vera-families/faces* '(((:fix :roman) . "VeraMono.ttf") ((:fix :italic) . "VeraMoIt.ttf") ((:fix (:bold :italic)) . "VeraMoBI.ttf") @@ -386,8 +386,7 @@

;;; Here are alternate mappings for the DejaVu family of fonts, which ;;; are a derivative of Vera with improved unicode coverage. -#+NIL -(defparameter *families/faces* +(defparameter *dejavu-families/faces* '(((:FIX :ROMAN) . "DejaVuSansMono.ttf") ((:FIX :ITALIC) . "DejaVuSansMono-Oblique.ttf") ((:FIX (:BOLD :ITALIC)) . "DejaVuSansMono-BoldOblique.ttf") @@ -404,8 +403,9 @@ ((:SANS-SERIF (:ITALIC :BOLD)) . "DejaVuSans-BoldOblique.ttf") ((:SANS-SERIF :BOLD) . "DejaVuSans-Bold.ttf")))

+(defvar *families/faces* *vera-families/faces*)

-(defvar *freetype-font-path*) +(defparameter *freetype-font-path* #p"/usr/share/fonts/truetype/ttf-dejavu/")

(fmakunbound 'clim-clx::text-style-to-x-font)

--- /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2008/01/01 18:44:39 1.8 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/mcclim-freetype.asd 2008/01/17 07:57:55 1.9 @@ -34,46 +34,15 @@ #+sbcl ((:file "freetype-package") (:uncompiled-cl-source-file "freetype-ffi") - (:file "freetype-fonts")) + (:file "freetype-fonts") + (:file "fontconfig")) #-sbcl ((:file "freetype-package-cffi") (:uncompiled-cl-source-file "freetype-cffi") (:file "freetype-fonts-cffi")))

-;;; Freetype autodetection - -(defun parse-fontconfig-output (s) - (let* ((match-string (concatenate 'string (string #\Tab) "file:")) - (matching-line - (loop for l = (read-line s nil nil) - while l - if (= (mismatch l match-string) (length match-string)) - do (return l))) - (filename (when matching-line - (probe-file - (subseq matching-line - (1+ (position #" matching-line :from-end nil :test #'char=)) - (position #" matching-line :from-end t :test #'char=)))))) - (when filename - (make-pathname :directory (pathname-directory filename))))) - -(defun warn-about-unset-font-path () - (warn "~%~%NOTE:~%~ -* Remember to set mcclim-freetype:*freetype-font-path* to the - location of the Bitstream Vera family of fonts on disk. If you - don't have them, get them from http://www.gnome.org/fonts/~%~%~%")) - (defmethod perform :after ((o load-op) (s (eql (asdf:find-system :mcclim-freetype)))) - (unless - (setf (symbol-value (intern "*FREETYPE-FONT-PATH*" :mcclim-freetype)) - (find-bitstream-fonts)) - (warn-about-unset-font-path))) + "Detect fonts using fc-match" + (funcall (find-symbol (symbol-name '#:autoconfigure-fonts) :mcclim-freetype)))

-(defun find-bitstream-fonts () - (with-input-from-string - (s (with-output-to-string (asdf::*verbose-out*) - (let ((code (asdf:run-shell-command "fc-match -v Bitstream Vera"))) - (unless (zerop code) - (warn "~&fc-match failed with code ~D.~%" code))))) - (parse-fontconfig-output s)))

--- /project/mcclim/cvsroot/mcclim/Experimental/freetype/fontconfig.lisp 2008/01/17 07:57:55 NONE +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/fontconfig.lisp 2008/01/17 07:57:55 1.1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: MCCLIM-FREETYPE; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Experimental FreeType support ;;; Created: 2003-05-25 16:32 ;;; Author: Gilbert Baumann unk6@rz.uni-karlsruhe.de ;;; License: LGPL (See file COPYING for details). ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2008 by Andy Hefner

;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.

(in-package :MCCLIM-FREETYPE)

(defparameter *family-names* '((:serif . "Serif") (:sans-serif . "Sans") (:fix . "Mono")))

(defparameter *fontconfig-faces* '((:roman . "") (:bold . "bold") (:italic . "oblique") ((:bold :italic) . "bold:oblique")))

(defun parse-fontconfig-output (s) (let* ((match-string (concatenate 'string (string #\Tab) "file:")) (matching-line (loop for l = (read-line s nil nil) while l if (= (mismatch l match-string) (length match-string)) do (return l))) (filename (when matching-line (probe-file (subseq matching-line (1+ (position #" matching-line :from-end nil :test #'char=)) (position #" matching-line :from-end t :test #'char=)))))) (when filename (parse-namestring filename))))

(defun warn-about-unset-font-path () (cerror "Proceed" "~%~%NOTE:~%~ * McCLIM was unable to configure itself automatically using fontconfig. Therefore you must configure it manually. Remember to set mcclim-freetype:*freetype-font-path* to the location of the Bitstream Vera family of fonts on disk. If you don't have them, get them from http://www.gnome.org/fonts/~%"))

(defun find-bitstream-font (font-fc-name) (with-input-from-string (s (with-output-to-string (asdf::*verbose-out*) (let ((code (asdf:run-shell-command "fc-match -v "~A"" font-fc-name))) (unless (zerop code) (warn "~&fc-match failed with code ~D.~%" code))))) (parse-fontconfig-output s)))

(defun fontconfig-name (family face) (format nil "~A:~A" family face))

(defun build-font/family-map (&optional (families *family-names*)) (loop for family in families nconcing (loop for face in *fontconfig-faces* as filename = (find-bitstream-font (fontconfig-name (cdr family) (cdr face))) when (null filename) do (return-from build-font/family-map nil) collect (cons (list (car family) (car face)) filename))))

(defun autoconfigure-fonts () (let ((map (build-font/family-map))) (if map (setf *families/faces* map) (warn-about-unset-font-path))))