Permalink
Browse files

add features, tested under cygwin, ensure directory exists ~/.fonts

  • Loading branch information...
1 parent 37301b4 commit a9a02cc66174ae68f1043693410e56a2fb933fb6 @filonenko-mikhail committed Aug 7, 2012
Showing with 18 additions and 11 deletions.
  1. +2 −1 clx-truetype.asd
  2. +7 −5 font-cache.lisp
  3. +9 −5 test/hello-world.lisp
View
3 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")
View
12 font-cache.lisp
@@ -1,9 +1,9 @@
(in-package #:clx-truetype)
-(defvar *font-dirs* #+unix (list "/usr/share/fonts/"
- (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") "/")))))
@@ -12,7 +12,7 @@
;;(pushnew (xlib:font-path *display*) *font-dirs*)
(defun cache-font-file (pathname)
"Caches font file."
- (ignore-errors
+ (handler-case
(zpb-ttf:with-font-loader (font pathname)
(multiple-value-bind (hash-table exists-p)
(gethash (zpb-ttf:family-name font) *font-cache*
@@ -21,7 +21,8 @@
pathname)
(unless exists-p
(setf (gethash (zpb-ttf:family-name font) *font-cache*)
- hash-table))))))
+ hash-table))))
+ (condition () (return-from cache-font-file))))
(defun ttf-pathname-test (pathname)
(string-equal "ttf" (pathname-type pathname)))
@@ -37,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 ()
View
14 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*)))))

0 comments on commit a9a02cc

Please sign in to comment.