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 &key (collection-index 0))
  53   (let ((magic (read-uint32 input-stream))
  54         (font-count))
  55     (when (/= magic #x00010000 #x74727565 #x74746366)
  56       (error 'bad-magic
  57              :location "font header"
  58              :expected-values (list #x00010000 #x74727565 #x74746366)
  59              :actual-value magic))
  60     (when (= magic #x74746366)
  61       (let ((version (read-uint32 input-stream)))
  62         (check-version "ttc header" version #x00010000 #x00020000)
  63         (setf font-count (read-uint32 input-stream))
  64         (let* ((offset-table (make-array font-count))
  65                (dsig))
  66           (when (> collection-index font-count)
  67             (error 'unsupported-value
  68                    :description "Font index out of range"
  69                    :actual-value collection-index
  70                    :expected-values (list font-count)))
  71           (loop for i below font-count
  72                 do (setf (aref offset-table i) (read-uint32 input-stream)))
  73           (when (= version #x00020000)
  74             (let ((flag (read-uint32 input-stream))
  75                   (length (read-uint32 input-stream))
  76                   (offset (read-uint32 input-stream)))
  77               (list flag length offset)
  78               (when (= #x44534947 flag)
  79                 (setf dsig (list length offset)))))
  80           ;; seek to font offset table
  81           (file-position input-stream (aref offset-table collection-index))
  82           (let ((magic2 (read-uint32 input-stream)))
  83             (when (/= magic2 #x00010000 #x74727565)
  84               (error 'bad-magic
  85                      :location "font header"
  86                      :expected-values (list #x00010000 #x74727565)
  87                      :actual-value magic2))))))
  88
  89     (let* ((table-count (read-uint16 input-stream))
  90            (font-loader (make-instance 'font-loader
  91                                        :input-stream input-stream
  92                                        :table-count table-count
  93                                        :collection-font-cont font-count
  94                                        :collection-font-index
  95                                        (when font-count
  96                                          collection-index))))
  97       ;; skip the unused stuff:
  98       ;; searchRange, entrySelector, rangeShift
  99       (read-uint16 input-stream)
 100       (read-uint16 input-stream)
 101       (read-uint16 input-stream)
 102       (loop repeat table-count
 103             for tag = (read-uint32 input-stream)
 104             for checksum = (read-uint32 input-stream)
 105             for offset = (read-uint32 input-stream)
 106             for size = (read-uint32 input-stream)
 107             do (setf (gethash tag (tables font-loader))
 108                      (make-instance 'table-info
 109                                     :offset offset
 110                                     :name (number->tag tag)
 111                                     :size size)))
 112       (load-maxp-info font-loader)
 113       (load-head-info font-loader)
 114       (load-kern-info font-loader)
 115       (load-loca-info font-loader)
 116       (load-name-info font-loader)
 117       (load-cmap-info font-loader)
 118       (load-post-info font-loader)
 119       (load-hhea-info font-loader)
 120       (load-hmtx-info font-loader)
 121       (setf (glyph-cache font-loader)
 122             (make-array (glyph-count font-loader) :initial-element nil))
 123       font-loader)))
 124
 125 (defun open-font-loader-from-file (thing &key (collection-index 0))
 126   (let ((stream (open thing
 127                       :direction :input
 128                       :element-type '(unsigned-byte 8))))
 129     (let ((font-loader (open-font-loader-from-stream
 130                         stream :collection-index collection-index)))
 131       (arrange-finalization font-loader stream)
 132       font-loader)))
 133
 134 (defun open-font-loader (thing &key (collection-index 0))
 135   (typecase thing
 136     (font-loader
 137      (cond
 138        ((= collection-index (collection-font-index thing))
 139         (unless (open-stream-p (input-stream thing))
 140           (setf (input-stream thing) (open (input-stream thing))))
 141         thing)
 142        (t
 143         (open-font-loader-from-file (input-stream thing)
 144                                     :collection-index collection-index))))
 145     (stream
 146      (if (open-stream-p thing)
 147          (open-font-loader-from-stream thing :collection-index collection-index)
 148          (error "~A is not an open stream" thing)))
 149     (t
 150      (open-font-loader-from-file thing :collection-index collection-index))))
 151
 152 (defun close-font-loader (loader)
 153   (close (input-stream loader)))
 154
 155 (defmacro with-font-loader ((loader file &key (collection-index 0)) &body body)
 156   `(let (,loader)
 157     (unwind-protect
 158          (progn
 159            (setf ,loader (open-font-loader ,file
 160                                            :collection-index ,collection-index))
 161            ,@body)
 162       (when ,loader
 163         (close-font-loader ,loader)))))
 164