[mcclim-cvs] CVS mcclim/Experimental/freetype
ahefner
ahefner at common-lisp.net
Thu Jan 17 07:57:55 UTC 2008
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 at 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))))
More information about the Mcclim-cvs
mailing list