Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

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

  • Loading branch information...
commit a9a02cc66174ae68f1043693410e56a2fb933fb6 1 parent 37301b4
Michael Filonenko authored
3  clx-truetype.asd
@@ -12,7 +12,8 @@
12 12 #:cl-paths-ttf
13 13 #:cl-aa
14 14 #:cl-fad
15   - #:cl-store)
  15 + #:cl-store
  16 + #:trivial-features)
16 17 :components ((:file "package")
17 18 (:file "clx-utils")
18 19 (:file "font-cache")
12 font-cache.lisp
... ... @@ -1,9 +1,9 @@
1 1
2 2 (in-package #:clx-truetype)
3 3
4   -(defvar *font-dirs* #+unix (list "/usr/share/fonts/"
5   - (namestring (merge-pathnames ".fonts/" (user-homedir-pathname))))
6   - #+macos (list "/Library/Fonts/")
  4 +(defvar *font-dirs* #+(or unix netbsd openbsd freebsd) (list "/usr/share/fonts/"
  5 + (namestring (merge-pathnames ".fonts/" (user-homedir-pathname))))
  6 + #+darwin (list "/Library/Fonts/")
7 7 #+windows (list (namestring
8 8 (merge-pathnames "fonts/"
9 9 (pathname (concatenate 'string (asdf:getenv "WINDIR") "/")))))
@@ -12,7 +12,7 @@
12 12 ;;(pushnew (xlib:font-path *display*) *font-dirs*)
13 13 (defun cache-font-file (pathname)
14 14 "Caches font file."
15   - (ignore-errors
  15 + (handler-case
16 16 (zpb-ttf:with-font-loader (font pathname)
17 17 (multiple-value-bind (hash-table exists-p)
18 18 (gethash (zpb-ttf:family-name font) *font-cache*
@@ -21,7 +21,8 @@
21 21 pathname)
22 22 (unless exists-p
23 23 (setf (gethash (zpb-ttf:family-name font) *font-cache*)
24   - hash-table))))))
  24 + hash-table))))
  25 + (condition () (return-from cache-font-file))))
25 26
26 27 (defun ttf-pathname-test (pathname)
27 28 (string-equal "ttf" (pathname-type pathname)))
@@ -37,6 +38,7 @@
37 38 (dolist (font-dir *font-dirs*)
38 39 (fad:walk-directory font-dir #'cache-font-file :if-does-not-exist :ignore
39 40 :test #'ttf-pathname-test))
  41 + (ensure-directories-exist +font-cache-filename+)
40 42 (cl-store:store *font-cache* +font-cache-filename+))
41 43
42 44 (defun get-font-families ()
14 test/hello-world.lisp
@@ -8,14 +8,18 @@
8 8
9 9 (in-package :clx-truetype-test)
10 10
11   -(defparameter *display* (xlib:open-default-display))
  11 +(defparameter *display* nil)
12 12 ;;(defparameter *display* (xlib:open-default-display "192.168.1.101:0.0"))
13 13
14   -(defparameter *screen* (xlib:display-default-screen *display*))
15   -(defparameter *root* (xlib:screen-root *screen*))
  14 +(defparameter *screen* nil)
  15 +(defparameter *root* nil)
16 16
17 17 (defun show-window ()
18   - (let* ((black (xlib:screen-black-pixel *screen*))
  18 + (let* ((*display* #-windows (xlib:open-default-display)
  19 + #+windows (xlib:open-display "127.0.0.1" :protocol :tcp))
  20 + (*screen* (xlib:display-default-screen *display*))
  21 + (*root* (xlib:screen-root *screen*))
  22 + (black (xlib:screen-black-pixel *screen*))
19 23 (white (xlib:screen-white-pixel *screen*))
20 24 (window
21 25 (xlib:create-window :parent *root* :x 0 :y 0 :width 640 :height 480
@@ -54,4 +58,4 @@
54 58 (progn
55 59 (xlib:free-gcontext grackon)
56 60 (xlib:destroy-window window)
57   - (xlib:display-force-output *display*)))))
  61 + (xlib:close-display *display*)))))

0 comments on commit a9a02cc

Please sign in to comment.
Something went wrong with that request. Please try again.