[mcclim-cvs] CVS mcclim/Experimental/freetype

[ahefner]

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype
In directory clnet:/tmp/cvs-serv8112

Modified Files:
	freetype-fonts.lisp 
Log Message:
Attempt to improve handling of broken freetype paths.

Error immediately when a TTF file cannot be found. If call-next-method
here was a feature, I hope no one misses it. Added potentially helpful
restart.



--- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp	2008/01/06 01:37:06	1.15
+++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp	2008/01/13 20:23:59	1.16
@@ -137,7 +137,7 @@
   (or (pop (display-free-glyph-ids display))
       (incf (display-free-glyph-id-counter display))))
 
-(defvar *font-hash*
+(defparameter *font-hash*
   (make-hash-table :test #'equalp))
 
 (defstruct (glyph-info (:constructor glyph-info (id width height left right top)))
@@ -386,7 +386,6 @@
 
 ;;; Here are alternate mappings for the DejaVu family of fonts, which
 ;;; are a derivative of Vera with improved unicode coverage.
-
 #+NIL
 (defparameter *families/faces* 
   '(((:FIX :ROMAN) . "DejaVuSansMono.ttf") 
@@ -436,6 +435,24 @@
 
 (defparameter *free-type-face-hash* (make-hash-table :test #'equal))
 
+(define-condition missing-font (simple-error)
+  ((filename :reader missing-font-filename :initarg :filename))
+  (:report (lambda (condition stream)
+             (format stream  "Cannot access ~W~%Your *freetype-font-path* is currently ~W~%The following files should exist:~&~{  ~A~^~%~}"
+                     (missing-font-filename condition)
+                     *freetype-font-path*
+                     (mapcar #'cdr *families/faces*)))))
+
+(defun invoke-with-freetype-path-restart (continuation)
+  (restart-case (funcall continuation)
+    (change-font-path (new-path)
+      :report (lambda (stream) (format stream "Retry with alternate freetype font path"))
+      :interactive (lambda ()
+                     (format t "Enter new value: ")
+                     (list (read-line)))
+      (setf *freetype-font-path* new-path)
+      (invoke-with-freetype-path-restart continuation))))
+
 (let (lookaside)
   (defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style standard-text-style))
     (flet ((f ()
@@ -453,14 +470,18 @@
                                     (let* ((font-path-relative (cdr (assoc (list family face) *families/faces*
                                                                            :test #'equal)))
                                            (font-path (namestring (merge-pathnames font-path-relative *freetype-font-path*))))
+                                      (unless (and font-path (probe-file font-path))
+                                        (error 'missing-font :filename font-path))
+                                      #+NIL
                                       (if (and font-path (probe-file font-path))
                                           (make-free-type-face display font-path size)
-                                          (call-next-method)))))))
+                                          (call-next-method))
+                                      (make-free-type-face display font-path size))))))
                        (t
-                        (call-next-method)))))))      
+                        (call-next-method)))))))
       (cdr (if (eq (car lookaside) text-style)
                lookaside
-               (setf lookaside (cons text-style (f))))))))
+               (setf lookaside (cons text-style (invoke-with-freetype-path-restart #'f))))))))
 
 (defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style)
   (error "You lost: ~S." text-style))