common-lisp/goose121.clx-truetype
1
0
Fork 0
mirror of https://github.com/goose121/clx-truetype.git synced 2026-09-10 07:16:25 -04:00
Code Issues Actions Packages Projects Releases Wiki Activity

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

Browse source
This commit is contained in:
Michael Filonenko 2012-08-07 11:16:35 +06:00
parent 37301b4441
commit a9a02cc661
3 changed files with 18 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
clx-truetype.asd
View file

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

12
font-cache.lisp
View file

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

14
test/hello-world.lisp
View file

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