Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
81 lines (71 sloc) 3.07 KB
(in-package #:clx-truetype)
(defvar *font-dirs*
#+(or unix netbsd openbsd freebsd)
(list "/usr/share/fonts/"
#+darwin "/Library/Fonts/"
(namestring (merge-pathnames ".fonts/" (user-homedir-pathname))))
#+windows (list (namestring
(merge-pathnames "fonts/"
(pathname (concatenate 'string (asdf:getenv "WINDIR") "/")))))
"List of directories, which contain TrueType fonts.")
;; family ->
;; subfamily -> filename
;; subfamily -> filename
;;(defparameter *font-cache* (make-hash-table :test 'equal))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter +font-cache-filename+
#.(merge-pathnames "font-cache.sexp"
(merge-pathnames ".fonts/" (user-homedir-pathname)))))
(eval-when (:load-toplevel :execute)
(defparameter *font-cache*
(if (fad:file-exists-p +font-cache-filename+)
(cl-store:restore +font-cache-filename+)
(make-hash-table :test 'equal))
"Hashmap for caching font families, subfamilies and files."))
;;(pushnew (xlib:font-path *display*) *font-dirs*)
(defun cache-font-file (pathname)
"Caches font file."
(declare (special *font-cache*))
(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)
(unless exists-p
(setf (gethash (zpb-ttf:family-name font) *font-cache*)
(condition () (return-from cache-font-file))))
(defun ttf-pathname-test (pathname)
(string-equal "ttf" (pathname-type pathname)))
(defun cache-fonts ()
"Caches fonts from @refvar{*font-dirs*} directories."
(declare (special *font-cache*))
(clrhash *font-cache*)
(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 ()
"Returns cached font families."
(declare (special *font-cache*))
(let ((result (list)))
(maphash (lambda (key value)
(declare (ignorable value))
(push key result)) *font-cache*)
(nreverse result)))
(defun get-font-subfamilies (font-family)
"Returns font subfamilies for current @var{font-family}. For e.g. regular, italic, bold, etc."
(declare (special *font-cache*))
(let ((result (list)))
(maphash (lambda (family value)
(declare (ignorable family))
(when (string-equal font-family family)
(maphash (lambda (subfamily pathname)
(declare (ignorable pathname))
(push subfamily result)) value)
(return-from get-font-subfamilies
(nreverse result)))) *font-cache*)
(nreverse result)))