font-loader-interface.lisp

   1 ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved
   2 ;;;
   3 ;;; Redistribution and use in source and binary forms, with or without
   4 ;;; modification, are permitted provided that the following conditions
   5 ;;; are met:
   6 ;;;
   7 ;;;   * Redistributions of source code must retain the above copyright
   8 ;;;     notice, this list of conditions and the following disclaimer.
   9 ;;;
  10 ;;;   * Redistributions in binary form must reproduce the above
  11 ;;;     copyright notice, this list of conditions and the following
  12 ;;;     disclaimer in the documentation and/or other materials
  13 ;;;     provided with the distribution.
  14 ;;;
  15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  18 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26 ;;;
  27 ;;; Interface functions for creating, initializing, and closing a
  28 ;;; FONT-LOADER object.
  29 ;;;
  30 ;;; $Id: font-loader-interface.lisp,v 1.6 2006/03/23 22:20:35 xach Exp $
  31
  32 (in-package #:zpb-ttf)
  33
  34 (defun arrange-finalization (object stream)
  35   (flet ((quietly-close (&optional object)
  36            (declare (ignore object))
  37            (ignore-errors (close stream))))
  38     #+sbcl
  39     (sb-ext:finalize object #'quietly-close)
  40     #+cmucl
  41     (ext:finalize object #'quietly-close)
  42     #+clisp
  43     (ext:finalize object #'quietly-close)
  44     #+allegro
  45     (excl:schedule-finalization object #'quietly-close)))
  46
  47
  48 ;;;
  49 ;;; FIXME: move most/all of this stuff into initialize-instance
  50 ;;;
  51
  52 (defun open-font-loader-from-file (font-file)
  53   (let* ((input-stream (open font-file
  54                              :direction :input
  55                              :element-type '(unsigned-byte 8)))
  56          (magic (read-uint32 input-stream)))
  57     (when (/= magic #x00010000 #x74727565)
  58       (error 'bad-magic
  59              :location "font header"
  60              :expected-values (list #x00010000 #x74727565)
  61              :actual-value magic))
  62     (let* ((table-count (read-uint16 input-stream))
  63            (font-loader (make-instance 'font-loader
  64                                        :input-stream input-stream
  65                                        :table-count table-count)))
  66       (arrange-finalization font-loader input-stream)
  67       ;; skip the unused stuff:
  68       ;; searchRange, entrySelector, rangeShift
  69       (read-uint16 input-stream)
  70       (read-uint16 input-stream)
  71       (read-uint16 input-stream)
  72       (loop repeat table-count
  73             for tag = (read-uint32 input-stream)
  74             for checksum = (read-uint32 input-stream)
  75             for offset = (read-uint32 input-stream)
  76             for size = (read-uint32 input-stream)
  77             do (setf (gethash tag (tables font-loader))
  78                      (make-instance 'table-info
  79                                     :offset offset
  80                                     :name (number->tag tag)
  81                                     :size size)))
  82       (load-maxp-info font-loader)
  83       (load-head-info font-loader)
  84       (load-kern-info font-loader)
  85       (load-loca-info font-loader)
  86       (load-name-info font-loader)
  87       (load-cmap-info font-loader)
  88       (load-post-info font-loader)
  89       (load-hhea-info font-loader)
  90       (load-hmtx-info font-loader)
  91       (setf (glyph-cache font-loader)
  92             (make-array (glyph-count font-loader) :initial-element nil))
  93       font-loader)))
  94
  95 (defun open-font-loader (thing)
  96   (typecase thing
  97     (font-loader
  98      (unless (open-stream-p (input-stream thing))
  99        (setf (input-stream thing) (open (input-stream thing))))
 100      thing)
 101     (t
 102      (open-font-loader-from-file thing))))
 103
 104 (defun close-font-loader (loader)
 105   (close (input-stream loader)))
 106
 107 (defmacro with-font-loader ((loader file) &body body)
 108   `(let (,loader)
 109     (unwind-protect
 110          (progn
 111            (setf ,loader (open-font-loader ,file))
 112            ,@body)
 113       (when ,loader
 114         (close-font-loader ,loader)))))
 115