Merge branch 'master' of github.com:filonenko-mikhail/clx-truetype

dmb2 · Aug 30, 2012 · 3235774 · 3235774
2 parents b2a289c a9a02cc
commit 3235774
Show file tree

Hide file tree

Showing 3 changed files with 29 additions and 19 deletions.
diff --git a/clx-truetype.asd b/clx-truetype.asd
@@ -12,7 12,8 @@
  #:cl-paths-ttf
  #:cl-aa
  #:cl-fad
- #:cl-store)
  #:cl-store
  #:trivial-features)
  :components ((:file "package")
  (:file "clx-utils")
  (:file "font-cache")

diff --git a/font-cache.lisp b/font-cache.lisp
@@ -1,24 1,28 @@
 
 (in-package #:clx-truetype)
 
-(defvar *font-dirs* # unix (list "/usr/share/fonts/TTF/"
- (namestring (merge-pathnames ".fonts/" (user-homedir-pathname))))
- # macos (list "/Library/Fonts/")
 (defvar *font-dirs* # (or unix netbsd openbsd freebsd) (list "/usr/share/fonts/"
  (namestring (merge-pathnames ".fonts/" (user-homedir-pathname))))
  # darwin (list "/Library/Fonts/")
  # windows (list (namestring
  (merge-pathnames "fonts/" 
  (pathname (concatenate 'string (asdf:getenv "WINDIR") "/")))))
  "List of directories, which contain TrueType fonts.")
 
 ;;(pushnew (xlib:font-path *display*) *font-dirs*)
 (defun cache-font-file (pathname)
  "Caches font file."
- (ignore-errors 
- (zpb-ttf:with-font-loader (font pathname)
- (multiple-value-bind (hash-table exists-p)
- (gethash (zpb-ttf:family-name font) *font-cache*
- (make-hash-table :test 'equal))
- (setf (gethash (zpb-ttf:subfamily-name font) hash-table)
- pathname)
- (unless exists-p
- (setf (gethash (zpb-ttf:family-name font) *font-cache*)
- hash-table))))))
  (handler-case 
  (zpb-ttf:with-font-loader (font pathname)
  (multiple-value-bind (hash-table exists-p)
  (gethash (zpb-ttf:family-name font) *font-cache*
  (make-hash-table :test 'equal))
  (setf (gethash (zpb-ttf:subfamily-name font) hash-table)
  pathname)
  (unless exists-p
  (setf (gethash (zpb-ttf:family-name font) *font-cache*)
  hash-table))))
  (condition () (return-from cache-font-file))))
 
 (defun ttf-pathname-test (pathname)
  (string-equal "ttf" (pathname-type pathname)))
@@ -34,6 38,7 @@
  (dolist (font-dir *font-dirs*)
  (fad:walk-directory font-dir #'cache-font-file :if-does-not-exist :ignore
  :test #'ttf-pathname-test))
  (ensure-directories-exist  font-cache-filename )
  (cl-store:store *font-cache*  font-cache-filename ))
 
 (defun get-font-families ()

diff --git a/test/hello-world.lisp b/test/hello-world.lisp
@@ -8,14 8,18 @@
 
 (in-package :clx-truetype-test)
 
-(defparameter *display* (xlib:open-default-display))
 (defparameter *display* nil)
 ;;(defparameter *display* (xlib:open-default-display "192.168.1.101:0.0"))
 
-(defparameter *screen* (xlib:display-default-screen *display*))
-(defparameter *root* (xlib:screen-root *screen*))
 (defparameter *screen* nil)
 (defparameter *root* nil)
 
 (defun show-window ()
- (let* ((black (xlib:screen-black-pixel *screen*))
  (let* ((*display* #-windows (xlib:open-default-display)
  # windows (xlib:open-display "127.0.0.1" :protocol :tcp))
  (*screen* (xlib:display-default-screen *display*))
  (*root* (xlib:screen-root *screen*))
  (black (xlib:screen-black-pixel *screen*))
  (white (xlib:screen-white-pixel *screen*))
  (window
  (xlib:create-window :parent *root* :x 0 :y 0 :width 640 :height 480 
@@ -54,4 58,4 @@
  (progn
  (xlib:free-gcontext grackon)
  (xlib:destroy-window window)
- (xlib:display-force-output *display*)))))
  (xlib:close-display *display*)))))