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-stream (input-stream)
  53   (let ((magic (read-uint32 input-stream)))
  54     (when (/= magic #x00010000 #x74727565)
  55       (error 'bad-magic
  56              :location "font header"
  57              :expected-values (list #x00010000 #x74727565)
  58              :actual-value magic))
  59     (let* ((table-count (read-uint16 input-stream))
  60            (font-loader (make-instance 'font-loader
  61                                        :input-stream input-stream
  62                                        :table-count table-count)))
  63       ;; skip the unused stuff:
  64       ;; searchRange, entrySelector, rangeShift
  65       (read-uint16 input-stream)
  66       (read-uint16 input-stream)
  67       (read-uint16 input-stream)
  68       (loop repeat table-count
  69             for tag = (read-uint32 input-stream)
  70             for checksum = (read-uint32 input-stream)
  71             for offset = (read-uint32 input-stream)
  72             for size = (read-uint32 input-stream)
  73             do (setf (gethash tag (tables font-loader))
  74                      (make-instance 'table-info
  75                                     :offset offset
  76                                     :name (number->tag tag)
  77                                     :size size)))
  78       (load-maxp-info font-loader)
  79       (load-head-info font-loader)
  80       (load-kern-info font-loader)
  81       (load-loca-info font-loader)
  82       (load-name-info font-loader)
  83       (load-cmap-info font-loader)
  84       (load-post-info font-loader)
  85       (load-hhea-info font-loader)
  86       (load-hmtx-info font-loader)
  87       (setf (glyph-cache font-loader)
  88             (make-array (glyph-count font-loader) :initial-element nil))
  89       font-loader)))
  90
  91 (defun open-font-loader-from-file (thing)
  92   (let ((stream (open thing
  93                       :direction :input
  94                       :element-type '(unsigned-byte 8))))
  95     (let ((font-loader (open-font-loader-from-stream stream)))
  96       (arrange-finalization font-loader stream)
  97       font-loader)))
  98
  99 (defun open-font-loader (thing)
 100   (typecase thing
 101     (font-loader
 102      (unless (open-stream-p (input-stream thing))
 103        (setf (input-stream thing) (open (input-stream thing))))
 104      thing)
 105     (stream
 106      (if (open-stream-p thing)
 107          (open-font-loader-from-stream thing)
 108          (error "~A is not an open stream" thing)))
 109     (t
 110      (open-font-loader-from-file thing))))
 111
 112 (defun close-font-loader (loader)
 113   (close (input-stream loader)))
 114
 115 (defmacro with-font-loader ((loader file) &body body)
 116   `(let (,loader)
 117     (unwind-protect
 118          (progn
 119            (setf ,loader (open-font-loader ,file))
 120            ,@body)
 121       (when ,loader
 122         (close-font-loader ,loader)))))
 123